language-lustre (empty) → 1.0.0
raw patch · 36 files changed
+11837/−0 lines, 36 filesdep +GraphSCCdep +alex-toolsdep +arraysetup-changed
Dependencies added: GraphSCC, alex-tools, array, base, bytestring, containers, language-lustre, monadLib, panic, pretty, simple-get-opt, text
Files
- ChangeLog.md +7/−0
- LICENSE +13/−0
- Language/Lustre/AST.hs +656/−0
- Language/Lustre/Core.hs +349/−0
- Language/Lustre/Defines.hs +140/−0
- Language/Lustre/Driver.hs +214/−0
- Language/Lustre/Error.hs +99/−0
- Language/Lustre/ModelState.hs +205/−0
- Language/Lustre/Monad.hs +184/−0
- Language/Lustre/Name.hs +213/−0
- Language/Lustre/Panic.hs +16/−0
- Language/Lustre/Parser.y +1138/−0
- Language/Lustre/Parser/Lexer.x +427/−0
- Language/Lustre/Parser/Monad.hs +109/−0
- Language/Lustre/Phase.hs +22/−0
- Language/Lustre/Pretty.hs +539/−0
- Language/Lustre/Semantics/BuiltIn.hs +250/−0
- Language/Lustre/Semantics/Const.hs +220/−0
- Language/Lustre/Semantics/Core.hs +392/−0
- Language/Lustre/Semantics/Value.hs +80/−0
- Language/Lustre/Transform/Inline.hs +455/−0
- Language/Lustre/Transform/NoStatic.hs +1321/−0
- Language/Lustre/Transform/NoStruct.hs +985/−0
- Language/Lustre/Transform/OrderDecls.hs +738/−0
- Language/Lustre/Transform/ToCore.hs +606/−0
- Language/Lustre/TypeCheck.hs +1090/−0
- Language/Lustre/TypeCheck.hs-boot +10/−0
- Language/Lustre/TypeCheck/Constraint.hs +248/−0
- Language/Lustre/TypeCheck/Monad.hs +420/−0
- Language/Lustre/TypeCheck/Prims.hs +252/−0
- Language/Lustre/TypeCheck/Utils.hs +114/−0
- Language/Lustre/Utils.hs +15/−0
- Setup.hs +2/−0
- exe/Lustre.hs +143/−0
- exe/Options.hs +79/−0
- language-lustre.cabal +86/−0
+ ChangeLog.md view
@@ -0,0 +1,7 @@+# Revision history for language-lustre++## next -- TBA++## 1.0.0 -- 2026-07-06++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright (c) 2018 Iavor Diatchki++Permission to use, copy, modify, and/or distribute this software for any purpose+with or without fee is hereby granted, provided that the above copyright notice+and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS+OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER+TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF+THIS SOFTWARE.
+ Language/Lustre/AST.hs view
@@ -0,0 +1,656 @@+-- | Reference:+-- http://www-verimag.imag.fr/DIST-TOOLS/SYNCHRONE/lustre-v6/doc/lv6-ref-man.pdf+module Language.Lustre.AST+ ( Program(..)++ -- * Packages++ {- | We don't support packages beyond parsing them. -}++ , PackDecl(..)+ , Package(..)+ , PackageProvides(..)+++ -- * Top-Level Declarations+ , TopDecl(..)++ -- ** Types+ , TypeDecl(..)+ , TypeDef(..)+ , Type(..)+ , FieldType(..)+ , CType(..)+ , IClock(..)+ , CVar(..)++ -- ** Constants+ , ConstDef(..)++ -- ** Nodes+ , NodeDecl(..)+ , NodeInstDecl(..)+ , NodeProfile(..)+ , Safety(..)+ , NodeType(..)++ , InputBinder(..)+ , Binder(..)++ , NodeBody(..)+ , LocalDecl(..)+ , Equation(..)+ , AssertType(..)+ , LHS(..)+ , Selector(..)+ , ArraySlice(..)++ , Expression(..)+ , MergeCase(..)+ , ClockExpr(..)+ , NodeInst(..)++++ -- ** Contracts+ -- {- | Support for contracts is incomplete. -}+ , Contract(..)+ , ContractItem(..)+ , ContractDecl(..)++++ , eOp1+ , eOp2+ , eITE+ , eOpN++ , Callable(..)+ , PrimNode(..)+ , Iter(..)++ , StaticParam(..)+ , StaticArg(..)++ , Literal(..)++ , Field(..)+++ , Op1(..)+ , Op2(..)+ , OpN(..)++ , exprRangeMaybe+ , typeRangeMaybe+ , argRangeMaybe+ , eqnRangeMaybe++ , HasRange(..)+ , SourceRange(..)+ , SourcePos(..)+ ) where++import Data.Maybe(fromMaybe)++import AlexTools(SourceRange(..), SourcePos(..), HasRange(..), (<->))++import Language.Lustre.Panic+import Language.Lustre.Name++-- | A Lustre program. Currently we don't support packages beyond parsing.+data Program = ProgramDecls [TopDecl] -- ^ Some declarations+ | ProgramPacks [PackDecl] -- ^ Some packages+ deriving Show++-- | A package declaration. We can parse these, but not do anything with+-- them yet.+data PackDecl = PackDecl Package+ | PackInst Ident Ident [ (Ident, StaticArg) ]+ deriving Show++-- | This is used for both packages and models.+data Package = Package+ { packageName :: !Ident+ , packageUses :: ![Ident]+ , packageParams :: ![StaticParam] -- ^ Empty list for pacakges+ , packageProvides :: ![PackageProvides]+ , packageBody :: ![TopDecl]+ , packageRange :: !SourceRange+ } deriving Show++data PackageProvides =+ ProvidesConst !Ident !Type !(Maybe Expression)+ | ProvidesNode !NodeDecl+ | ProvidesType !TypeDecl+ deriving Show+++data TopDecl =+ DeclareType !TypeDecl+ | DeclareConst !ConstDef+ | DeclareNode !NodeDecl+ | DeclareNodeInst !NodeInstDecl+ | DeclareContract !ContractDecl+ deriving Show++-- | Declare a named type.+data TypeDecl = TypeDecl+ { typeName :: !Ident+ , typeDef :: !(Maybe TypeDef)+ -- ^ Types with no definitions are abstract.+ -- We do not have good support for abstract types at the moment.+ } deriving Show++++-- | A definition for a named type.+data TypeDef = IsType !Type -- ^ A type alias.+ | IsEnum ![ Ident ] -- ^ An enumeration type.+ | IsStruct ![ FieldType ] -- ^ A record type.+ deriving Show++-- | The type of value or a constant.+data Type =+ NamedType Name -- ^ A named type. See 'TypeDef'.+ | ArrayType Type Expression+ -- ^ An array type. The 'Expression' is for the size of the array.++ | IntType -- ^ Type of integers.+ | RealType -- ^ Type of real numbers.+ | BoolType -- ^ Type of boolean values.++ | IntSubrange Expression Expression+ -- ^ An interval subset of the integers. The 'Expression's are bounds.+ -- Their values are included in the interval.++ | TypeRange SourceRange Type+ -- ^ A type annotated with a source location.++ deriving Show+++-- | The type of the field of a structure.+data FieldType = FieldType+ { fieldName :: Label -- ^ The name of the field.+ , fieldType :: Type -- ^ The field's type.+ , fieldDefault :: Maybe Expression+ -- ^ Optional default constant value, used if the field is omitted.+ } deriving Show+++-- | Note: only one of the type or definition may be "Nothing".+data ConstDef = ConstDef+ { constName :: Ident+ , constType :: Maybe Type -- ^ Optional type annotation.+ , constDef :: Maybe Expression+ {- ^ Optional definition. If the definition is omitted, then the constant+ is abstract. In that case, the type cannot be omitted.++ Note that at the moment we don't have good support for abstract+ constants. -}+ } deriving Show+++data Contract = Contract+ { contractRange :: SourceRange+ , contractItems :: [ContractItem]+ } deriving Show++data ContractItem = GhostConst ConstDef+ | GhostVar Binder Expression+ | Assume Label Expression+ | Guarantee Label Expression+ | Mode Ident [Expression] [Expression]+ | Import Ident [Expression] [Expression]+ deriving Show++data ContractDecl = ContractDecl+ { cdName :: Ident+ , cdProfile :: NodeProfile+ , cdItems :: [ContractItem]+ , cdRange :: SourceRange+ } deriving Show+++-- | The declaration of a node.+data NodeDecl = NodeDecl+ { nodeSafety :: Safety+ , nodeExtern :: Bool+ , nodeType :: NodeType+ , nodeName :: Ident+ , nodeStaticInputs :: [StaticParam]+ , nodeProfile :: NodeProfile+ , nodeContract :: Maybe Contract+ , nodeDef :: Maybe NodeBody+ -- Must be "Nothing" if "nodeExtern" is set to "True"+ , nodeRange :: !SourceRange+ } deriving Show++-- | A named instantiation of a node with static parameters.+data NodeInstDecl = NodeInstDecl+ { nodeInstSafety :: Safety+ , nodeInstType :: NodeType+ , nodeInstName :: Ident+ , nodeInstStaticInputs :: [StaticParam]+ , nodeInstProfile :: Maybe NodeProfile+ , nodeInstDef :: NodeInst+ } deriving Show+++data NodeProfile = NodeProfile+ { nodeInputs :: [InputBinder]+ , nodeOutputs :: [Binder]+ } deriving Show+++data Safety = Safe -- ^ No side effects+ | Unsafe -- ^ May have side effects+ deriving (Show,Eq)++data NodeType = Node -- ^ Nodes may have memory (e.g., use @pre@)+ | Function -- ^ Functions do not have memory+ deriving (Show, Eq)++{- | These are used to support the notation where constant parameters+are intermixed with normal parameters, rather then bing factored+out before. -}+data InputBinder = InputBinder Binder+ | InputConst Ident Type+ deriving Show++-- | Introduces a local variable (not constant).+data Binder = Binder+ { binderDefines :: Ident+ , binderType :: CType+ } deriving Show+++data NodeBody = NodeBody+ { nodeLocals :: [LocalDecl]+ , nodeEqns :: [Equation]+ } deriving Show++data LocalDecl = LocalVar Binder+ | LocalConst ConstDef+ deriving Show++data Equation = Assert Label AssertType Expression -- ^ Assuming this+ | Property Label Expression -- ^ Prove this+ | IsMain SourceRange -- ^ This is the main node,+ -- use it if nothing specified+ | IVC [Ident]+ | Realizable [Ident]+ | Define [LHS Expression] Expression+ deriving Show++data AssertType = AssertPre -- failure of this assertion indicates an+ -- error in the system.++ | AssertEnv -- failure of this assertion idicates an+ -- unreachable system state.+ deriving Show++data LHS e = LVar Ident+ | LSelect (LHS e) (Selector e)+ deriving (Show,Eq,Ord)++data Selector e = SelectField Label+ | SelectElement e+ | SelectSlice (ArraySlice e)+ deriving (Show, Eq, Ord)++data ArraySlice e = ArraySlice+ { arrayStart :: e+ , arrayEnd :: e+ , arrayStep :: Maybe e+ } deriving (Show, Eq, Ord)+++data Expression = ERange !SourceRange !Expression+ | Var !Name+ | Lit !Literal++ | Const Expression CType+ {- ^ A use of a constant expression. These are introduced+ by the type checker---the parser does not generate them.-}++ | Expression `When` ClockExpr++ | Tuple ![Expression]+ -- ^ These are more like unboxed tuples in Haskell+++ | Array ![Expression]+ | Select Expression (Selector Expression)+ | Struct Name [Field Expression]+ -- ^ Create a new struct value. 'Name' is the struct type++ | UpdateStruct (Maybe Name) Expression [Field Expression]+ {- ^ Update a struct.+ The 'Name' is the struct type.+ The expression is the struct being updated. -}++ | WithThenElse Expression Expression Expression+ {- ^ Used for recursive definitions.+ The decision is evaluated in an earlier phase (i.e.,+ it is static), and then we get either the one stream or+ the other (i.e., it is not done point-wise as+ for if-then-else) -}++ | Merge Ident [MergeCase Expression]+ {- ^ Merge different clocked values. The branches are+ clocked on different values for the ident. -}++ | Call NodeInst [Expression] IClock (Maybe [CType])+ {- ^ Call a function.+ The clock expression allows for the node to be+ called only when the clock is active. This also+ includes the return types when they are known;+ prior to type checking, this will be Nothing. Once+ type checking has been performed, this will be the+ types of this call's results.+ -}+ deriving Show++-- | The first expression (the "pattern") should be a constant.+-- In fact, to check clocks, it is restricted to @true@, @false@, or a @Name@.+data MergeCase e = MergeCase Expression e+ deriving Show++-- | The clock activates when the identifier has the given expression.+-- In the surface syntax, the expression is restricted to+-- @true@, @false@, or a @Name@ (e.g., for to use an enum).+-- However, allowing arbitrary expressions is more convenient for manipulating+-- already validated syntax (e.g., we can allow arbitrary values).+data ClockExpr = WhenClock SourceRange Expression Ident+ deriving Show+++data NodeInst = NodeInst Callable [StaticArg]+ deriving Show++eOp1 :: SourceRange -> Op1 -> Expression -> Maybe [CType] -> Expression+eOp1 r op e tys = Call (NodeInst (CallPrim r (Op1 op)) []) [e] BaseClock tys++eOp2 :: SourceRange -> Op2 -> Expression -> Expression -> Maybe [CType] -> Expression+eOp2 r op e1 e2 tys = Call (NodeInst (CallPrim r (Op2 op)) []) [e1,e2] BaseClock tys++eITE :: SourceRange -> Expression -> Expression -> Expression -> Maybe [CType] -> Expression+eITE r e1 e2 e3 tys = Call (NodeInst (CallPrim r ITE) []) [e1,e2,e3] BaseClock tys++eOpN :: SourceRange -> OpN -> [Expression] -> Maybe [CType] -> Expression+eOpN r op es tys = Call (NodeInst (CallPrim r (OpN op)) []) es BaseClock tys++-- | Things that may be called+data Callable = CallUser Name -- ^ A user-defined node+ | CallPrim SourceRange PrimNode -- ^ A built-in node+ deriving Show++data PrimNode = Iter Iter+ | Op1 Op1+ | Op2 Op2+ | OpN OpN+ | ITE -- (bool,a,a) -> a -- (bool,a,a) -> a+ deriving Show++-- | Built-in array iterators+data Iter = IterFill -- ^ Like @unfold@, but returns state;+ -- can generate multiple arrays at once++ | IterRed -- ^ Like @fold@, but can fold multiple+ -- arrays at once++ | IterFillRed -- ^ @fill@ and @red@ at the same time:+ -- the folding accumulator is the unfolding+ -- state++ | IterMap -- ^ Like @fillred@ but with no accumulator++ | IterBoolRed -- ^ Check if number of @True@s is within+ -- some bound+ deriving Show++data StaticParam = TypeParam Ident+ | ConstParam Ident Type+ | NodeParam Safety NodeType Ident NodeProfile+ deriving Show++data StaticArg = TypeArg Type+ | ExprArg Expression+ | NodeArg NodeType NodeInst+ | ArgRange SourceRange StaticArg+ deriving Show+++data Literal = Int Integer | Real Rational | Bool Bool+ deriving (Show,Eq)++data Field e = Field { fName :: Label, fValue :: e }+ deriving Show++instance Functor Field where+ fmap f (Field l e) = Field l (f e)++instance Foldable Field where+ foldMap f (Field _ e) = f e++instance Traversable Field where+ traverse f (Field l e) = Field l <$> f e+++data Op1 = Not -- bool -> bool+ | Neg -- Num a => a -> a+ | Pre -- a -> a+ | Current -- a -> a+ | IntCast -- real -> int+ | FloorCast -- real -> int+ | RealCast -- int -> real+ deriving (Show, Eq, Ord)++data Op2 = FbyArr -- a -> a -> a+ | Fby -- a -> a -> a+ | CurrentWith -- like `current` but with a default value to use+ -- at the start instead of nil+ | And -- bool -> bool -> boo+ | Or -- bool -> bool -> boo+ | Xor -- bool -> bool -> boo+ | Implies -- bool -> bool -> boo+ | Eq -- a -> a -> bool+ | Neq -- a -> a -> bool+ | Lt -- Num a => a -> a -> bool+ | Leq -- Num a => a -> a -> bool+ | Gt -- Num a => a -> a -> bool+ | Geq -- Num a => a -> a -> bool+ | Mul | Mod | Div | Add | Sub | Power -- Num a => a -> a -> a+ | Replicate -- a -> (n:Int) -> a^n+ -- XXX: the `n` is a constante so perhaps we should+ -- represent it as a static parametere.+++ | Concat -- a^M -> a^N -> a^(M+N)+ deriving (Show, Eq, Ord)++data OpN = AtMostOne | Nor+ deriving (Show, Eq, Ord)+++--------------------------------------------------------------------------------+-- Type checking++-- | The type of a non-constant expression. We keep track of the clock,+-- and when the value may be updated.+data CType = CType { cType :: Type, cClock :: IClock }+ deriving Show++-- | A clock for a value.+data IClock =+ BaseClock+ {- ^ At the root node, this is the system's base clock.+ For other nodes, this refers to the clock of of the+ current node invocation. See the 'Call' expression. -}++ | KnownClock ClockExpr+ -- ^ A specific clock expression.++ | ClockVar CVar+ -- ^ A placeholder for a clock that is being inferred.+ -- Used only during type-checking+ deriving Show++-- | A clock variable, used during type checking to infer the clock of+-- some expressions.+newtype CVar = CVar Int deriving (Eq,Ord,Show)++++--------------------------------------------------------------------------------++instance HasRange e => HasRange (Field e) where+ range (Field x y) = x <-> y++instance HasRange ClockExpr where+ range (WhenClock r _ _) = r++-- | Get the source range associated with an expression, if any.+exprRangeMaybe :: Expression -> Maybe SourceRange+exprRangeMaybe expr =+ case expr of+ ERange r _ -> Just r+ Var x -> Just (range x)+ e `When` c -> Just (e <-> c)++ Const e _ -> exprRangeMaybe e++ Lit {} -> Nothing+ Tuple {} -> Nothing+ Array {} -> Nothing+ Select {} -> Nothing+ WithThenElse {} -> Nothing+ Merge {} -> Nothing+ Call {} -> Nothing+ Struct {} -> Nothing+ UpdateStruct {} -> Nothing+++-- | Get the source range associated with a type, if any.+typeRangeMaybe :: Type -> Maybe SourceRange+typeRangeMaybe ty =+ case ty of+ TypeRange r _ -> Just r+ NamedType n -> Just (range n)+ ArrayType {} -> Nothing+ IntType {} -> Nothing+ RealType {} -> Nothing+ BoolType {} -> Nothing+ IntSubrange {} -> Nothing+++-- | Get the source range of a static argument, if any.+argRangeMaybe :: StaticArg -> Maybe SourceRange+argRangeMaybe arg =+ case arg of+ ArgRange r _ -> Just r+ TypeArg t -> typeRangeMaybe t+ ExprArg e -> exprRangeMaybe e+ NodeArg {} -> Nothing+++-- | Get the source range of an equation, if any.+eqnRangeMaybe :: Equation -> Maybe SourceRange+eqnRangeMaybe eqn =+ case eqn of+ Assert _ _ e -> exprRangeMaybe e+ Property _ e -> exprRangeMaybe e+ IsMain r -> Just r+ IVC is ->+ case is of+ [] -> Nothing+ _ -> Just (range (head is) <-> range (last is))+ Realizable is ->+ case is of+ [] -> Nothing+ _ -> Just (range (head is) <-> range (last is))++++ Define ls e ->+ case ls of+ [] -> exprRangeMaybe e+ l:_ -> Just $ case exprRangeMaybe e of+ Nothing -> range l+ Just r -> range l <-> r++-- | Note that this is a partial function: it will panic if the+-- expression does not have an exact location.+instance HasRange Type where+ range ty = case typeRangeMaybe ty of+ Just r -> r+ Nothing -> panic "range@Type" [ "Type has no location"+ , show ty ]++-- | Note that this is a partial function: it will panic if the+-- expression does not have an exact location.+instance HasRange Expression where+ range expr =+ case exprRangeMaybe expr of+ Just r -> r+ Nothing -> panic "range@Expression" [ "Expression has no location"+ , show expr ]++-- | Note that this is a partial function: it will panic if the+-- expression does not have an exact location.+instance HasRange StaticArg where+ range arg =+ case argRangeMaybe arg of+ Just r -> r+ Nothing -> panic "range@StaticArg" [ "Static argument has no location"+ , show arg ]++instance HasRange NodeInst where+ range (NodeInst x _) = range x -- or args?++instance HasRange Callable where+ range c =+ case c of+ CallUser n -> range n+ CallPrim r _ -> r++instance HasRange Package where+ range = packageRange++instance HasRange e => HasRange (LHS e) where+ range lhs =+ case lhs of+ LVar i -> range i+ LSelect x y -> range x <-> range y+++instance HasRange e => HasRange (Selector e) where+ range s =+ case s of+ SelectField f -> range f+ SelectElement e -> range e+ SelectSlice a -> range a++instance HasRange e => HasRange (ArraySlice e) where+ range a =+ range (arrayStart a) <-> range (fromMaybe (arrayEnd a) (arrayStep a))++instance HasRange StaticParam where+ range param =+ case param of+ TypeParam i -> range i+ ConstParam i t -> range i <-> range t+ NodeParam _ _ i _ -> range i++instance HasRange NodeDecl where+ range = nodeRange++instance HasRange Contract where+ range = contractRange++instance HasRange ContractDecl where+ range = cdRange++
+ Language/Lustre/Core.hs view
@@ -0,0 +1,349 @@+{-# Language OverloadedStrings #-}+module Language.Lustre.Core+ (module Language.Lustre.Core, Literal(..)) where++import Data.Text(Text)+import Data.Map(Map)+import qualified Data.Map as Map+import Data.Set(Set)+import qualified Data.Set as Set+import Data.Graph(SCC(..))+import Data.Graph.SCC(stronglyConnComp)+import Text.PrettyPrint( Doc, text, (<+>), vcat+ , hsep, nest, parens, punctuate, comma, ($$) )+import qualified Text.PrettyPrint as PP++import Language.Lustre.AST (Literal(..))+import Language.Lustre.Name+import Language.Lustre.Pretty+import Language.Lustre.Panic(panic)+++newtype CoreName = CoreName OrigName+ deriving (Show,Eq,Ord)++data Type = TInt | TReal | TBool+ deriving Show++-- | A boolean clock. The base clock is always @true@.+data Clock = BaseClock | WhenTrue Atom+ deriving Show++-- | Type on a boolean clock.+data CType = Type `On` Clock+ deriving Show++typeOfCType :: CType -> Type+typeOfCType (t `On` _) = t++clockOfCType :: CType -> Clock+clockOfCType (_ `On` c) = c++data Binder = CoreName ::: CType+ deriving Show++data Atom = Lit Literal CType+ | Var CoreName+ | Prim Op [Atom] [CType]+ deriving Show++data Expr = Atom Atom+ | (Atom, CType) :-> Atom+ | Pre Atom+ | Atom `When` Atom+ | Current Atom+ | Merge (CoreName, CType) [(Literal, Atom)]+ deriving Show++data Op = Not | Neg+ | IntCast | RealCast | FloorCast+ | And | Or | Xor | Implies+ | Eq | Neq | Lt | Leq | Gt | Geq+ | Mul | Mod | Div | Add | Sub | Power+ | ITE+ | AtMostOne | Nor+ deriving Show++data Eqn = Binder := Expr+ deriving Show++infix 1 :=+infix 2 :::+infix 3 `On`++data Node = Node { nName :: Ident+ -- ^ Node name+ , nInputs :: [Binder]+ , nOutputs :: [Binder]+ , nAbstract :: [Binder]+ -- ^ Locals with no definitions++ , nAssuming :: [(Label,CoreName)]+ -- ^ Assuming that these are true++ , nShows :: [(Label,CoreName)]+ -- ^ Need to show that these are also true++ , nEqns :: [EqnGroup]+ -- ^ Groups of recursive equations.+ } deriving Show++-- | One or more equations.+data EqnGroup = NonRec Eqn -- ^ A non-recursive equation+ | Rec [Eqn] -- ^ A group of recursive equations.+ deriving Show++grpEqns :: EqnGroup -> [Eqn]+grpEqns g =+ case g of+ NonRec e -> [e]+ Rec es -> es+++--------------------------------------------------------------------------------+-- Ordering equations++usesAtom :: Atom -> Set CoreName+usesAtom atom =+ case atom of+ Lit _ _ -> Set.empty+ Var x -> Set.singleton x+ Prim _ as _ -> Set.unions (map usesAtom as)++usesExpr :: Expr -> Set CoreName+usesExpr expr =+ case expr of+ Atom a -> usesAtom a+ (a1, _) :-> a2 -> Set.union (usesAtom a1) (usesAtom a2)+ Pre _ -> Set.empty -- refer to values at previous instance+ a1 `When` a2 -> Set.union (usesAtom a1) (usesAtom a2)+ Current a -> usesAtom a+ Merge (i, _) bs -> Set.unions $ (usesAtom $ Var i) : ((usesAtom . snd) <$> bs)++usesClock :: Clock -> Set CoreName+usesClock c =+ case c of+ BaseClock -> Set.empty+ WhenTrue a -> usesAtom a++-- | Order the equations. Returns cycles on the left, if there are some.+orderedEqns :: [Eqn] -> [EqnGroup]+orderedEqns eqns = map cvt (stronglyConnComp graph)+ where+ graph = [ (eqn, x, Set.toList (Set.union (usesClock c) (usesExpr e)))+ | eqn <- eqns, let (x ::: _ `On` c) := e = eqn ]+ cvt x = case x of+ AcyclicSCC e -> NonRec e+ CyclicSCC es -> Rec es++coreNameTextName :: CoreName -> Text+coreNameTextName (CoreName x) = origNameTextName x++coreNameUID :: CoreName -> Int+coreNameUID (CoreName x) = rnUID x++coreNameFromOrig :: OrigName -> CoreName+coreNameFromOrig = CoreName++--------------------------------------------------------------------------------+-- Pretty Printing+++-- | Local identifier numbering. See `identVariants`.+type PPInfo = Map CoreName Int++noInfo :: PPInfo+noInfo = Map.empty++ppPrim :: Op -> Doc+ppPrim = text . show++ppIdent :: PPInfo -> CoreName -> Doc+ppIdent info i =+ case Map.lookup i info of+ Nothing -> pp (coreNameTextName i) PP.<> "$u" PP.<> PP.int (coreNameUID i)+ Just 0 -> pp i+ Just n -> pp i PP.<> "$" PP.<> PP.int n++ppType :: Type -> Doc+ppType ty =+ case ty of+ TInt -> text "int"+ TReal -> text "real"+ TBool -> text "bool"++ppCType :: PPInfo -> CType -> Doc+ppCType env (t `On` c) =+ case c of+ BaseClock -> ppType t+ WhenTrue a -> ppType t <+> "when" <+> ppAtom env a++ppBinder :: PPInfo -> Binder -> Doc+ppBinder env (x ::: t) = ppIdent env x <+> text ":" <+> ppCType env t++ppAtom :: PPInfo -> Atom -> Doc+ppAtom env atom =+ case atom of+ Lit l c -> case clockOfCType c of+ BaseClock -> pp l+ WhenTrue a -> pp l <+> "/* when" <+> ppAtom env a <+> "*/"+ Var x -> ppIdent env x+ Prim f as _ -> ppPrim f PP.<> ppTuple (map (ppAtom env) as)++ppExpr :: PPInfo -> Expr -> Doc+ppExpr env expr =+ case expr of+ Atom a -> ppAtom env a+ (a, _) :-> b -> ppAtom env a <+> text "->" <+> ppAtom env b+ Pre a -> text "pre" <+> ppAtom env a+ a `When` b -> ppAtom env a <+> text "when" <+> ppAtom env b+ Current a -> text "current" <+> ppAtom env a+ Merge (a, ty) bs ->+ text "merge" <+> ppAtom env (Var a) <+> vcat (ppBranch <$> bs)+ where+ ppBranch (lit, body) =+ ppAtom env (Lit lit ty) <+> "=>" <+> ppAtom env body++ppTuple :: [Doc] -> Doc+ppTuple ds = parens (hsep (punctuate comma ds))++ppEqn :: PPInfo -> Eqn -> Doc+ppEqn env (b := e) =+ ppBinder env b $$ nest 2 ("=" <+> ppExpr env e)++ppEqnGroup :: PPInfo -> EqnGroup -> Doc+ppEqnGroup env grp =+ case grp of+ NonRec eqn -> ppEqn env eqn+ Rec eqns -> "rec" $$ nest 2 (vcatSep (map (ppEqn env) eqns))++binderName :: Binder -> CoreName+binderName (c ::: _) = c++ppBinderName :: PPInfo -> Binder -> Doc+ppBinderName env b = ppIdent env $ binderName b++ppNode :: Node -> Doc+ppNode node =+ text "node" <+> pp (nName node) <+> ppTuple (map (ppBinder env) (nInputs node))+ $$ nest 2 ( text "returns" <+> ppTuple (map (ppBinderName env) (nOutputs node))+ $$ text "assumes" <+> ppTuple (map (ppIdent env . snd)+ (nAssuming node))+ $$ text "shows" <+> ppTuple (map (ppIdent env .snd) (nShows node))+ )+ $$ vcat [ "var" <+> ppBinder env b | b <- nAbstract node ]+ $$ text "let"+ $$ nest 2 (vcatSep (map (ppEqnGroup env) (nEqns node)))+ $$ text "tel"+ where+ env = identVariants node++++-- | Pick a normalized number for the identifier in a node.+-- Identifiers with the same text name are going to get different numbers.+-- Identifiers that only have one version around will get the number 0.+-- This is handy for pretty printing and exporting to external tools.+identVariants :: Node -> Map CoreName Int+identVariants node = Map.fromList+ $ concat+ $ Map.elems+ $ fmap (`zip` [ 0 .. ])+ $ Map.fromListWith (++)+ $ map binderInfo+ $ nInputs node +++ nAbstract node +++ [ b | g <- nEqns node, b := _ <- grpEqns g]++ where+ binderInfo (x ::: _) = (coreNameTextName x, [x])+++++instance Pretty Op where+ ppPrec _ = ppPrim++instance Pretty Type where+ ppPrec _ = ppType++instance Pretty CType where+ ppPrec _ = ppCType noInfo++instance Pretty Binder where+ ppPrec _ = ppBinder noInfo++instance Pretty Atom where+ ppPrec _ = ppAtom noInfo++instance Pretty Expr where+ ppPrec _ = ppExpr noInfo++instance Pretty Eqn where+ ppPrec _ = ppEqn noInfo++instance Pretty Node where+ ppPrec _ = ppNode++instance Pretty CoreName where+ ppPrec n (CoreName x) = ppPrec n x+++--------------------------------------------------------------------------------+-- Computing the the type of an expression.+++-- | Compute the typing environment for a node.+nodeEnv :: Node -> Map CoreName CType+nodeEnv nd = Map.fromList $ map fromB (nInputs nd) +++ map fromB (nOutputs nd) +++ map fromB (nAbstract nd) +++ map fromE (concatMap grpEqns (nEqns nd))+ where+ fromB (x ::: t) = (x,t)+ fromE (b := _) = fromB b++clockParent :: Map CoreName CType -> Clock -> Maybe Clock+clockParent env c =+ case c of+ BaseClock -> Nothing+ WhenTrue a -> Just (clockOfCType (typeOf env a))++class TypeOf t where+ -- | Get the type of something well-formed (panics if not).+ typeOf :: Map CoreName CType -> t -> CType++instance TypeOf Atom where+ typeOf env atom =+ case atom of+ Var x -> case Map.lookup x env of+ Just t -> t+ Nothing -> panic "typeOf" ["Undefined variable: " ++ showPP x]+ Lit _ ty -> ty++ prim@(Prim op as tys) ->+ case op of+ ITE -> case as of+ _ : b : _ -> typeOf env b+ _ -> panic "typeOf" ["Malformed ITE"]++ _ -> case tys of+ [ty] -> ty+ _ -> panic "typeOf" ["Prim has unexpected types:", show prim]++instance TypeOf Expr where+ typeOf env expr =+ case expr of+ Atom a -> typeOf env a+ (_, ty) :-> _ -> ty+ Pre a -> typeOf env a+ a `When` b -> let t `On` _ = typeOf env a+ in t `On` WhenTrue b+ Current a -> let t `On` c = typeOf env a+ Just c1 = clockParent env c+ in t `On` c1+ Merge (_, (_ `On` c1)) ((_, e):_) ->+ let t `On` _ = typeOf env e+ in t `On` c1+ Merge {} -> error "typeOf: malformed Merge"+
+ Language/Lustre/Defines.hs view
@@ -0,0 +1,140 @@+{-# Language OverloadedStrings, DataKinds, GeneralizedNewtypeDeriving #-}+module Language.Lustre.Defines+ ( getDefs+ , Defines(..)+ , Defs+ , noDefs+ , defNames+ , mergeDefs+ ) where++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Foldable(traverse_)+import MonadLib++import Language.Lustre.Name+import Language.Lustre.AST+import Language.Lustre.Monad+++-- | Identifiers groupes by namespace+type Defs = Map NameSpace (Set OrigName)++-- | Empty set of definitinos+noDefs :: Defs+noDefs = Map.empty++-- | Merge two sets of definitions+mergeDefs :: Defs -> Defs -> Defs+mergeDefs = Map.unionWith Set.union++-- | Collect all names in a definition map.+defNames :: Defs -> Set OrigName+defNames = Set.unions . Map.elems+++++getDefs :: Defines a =>+ a {- ^ Get definitions of this -} ->+ Maybe ModName {- ^ Where are we -} ->+ LustreM Defs+getDefs a mn =+ do (_,defs) <- runStateT [] $ runReaderT mn $ unDefM $ defines a+ pure (Map.fromListWith Set.union (map one defs))+ where+ one i = (thingNS (rnThing i), Set.singleton i)++newtype DefM a = DefM { unDefM ::+ WithBase LustreM+ [ ReaderT (Maybe ModName)+ , StateT [OrigName]+ ] a }+ deriving (Functor,Applicative,Monad)+++addDef :: Ident -> Thing -> DefM ()+addDef x t = DefM $+ do m <- ask+ n <- inBase newInt+ sets_ $ \is -> OrigName { rnModule = m+ , rnThing = t+ , rnIdent = x+ , rnUID = n } : is+++class Defines t where+ defines :: t -> DefM ()+++instance Defines TopDecl where+ defines ts =+ case ts of+ DeclareType td -> defines td+ DeclareConst cd -> defines cd+ DeclareNode nd -> defines nd+ DeclareNodeInst nid -> defines nid+ DeclareContract cd -> defines cd++instance Defines ConstDef where+ defines x = addDef (constName x) AConst++instance Defines TypeDecl where+ defines td = do addDef (typeName td) AType+ traverse_ defines (typeDef td)++instance Defines StaticParam where+ defines sp =+ case sp of+ TypeParam t -> addDef t AType+ ConstParam c _ -> addDef c AConst+ NodeParam _ _ i _ -> addDef i ANode++instance Defines InputBinder where+ defines ib =+ case ib of+ InputBinder b -> addDef (binderDefines b) AVal+ InputConst c _ -> addDef c AConst++-- | Note that binders are always used for values, not constants.+instance Defines Binder where+ defines b = addDef (binderDefines b) AVal++instance Defines TypeDef where+ defines td =+ case td of+ IsType _ -> pure ()+ IsEnum xs -> sequence_ [ addDef x AConst | x <- xs ]+ IsStruct _ -> pure ()+++instance Defines NodeInstDecl where+ defines nd = addDef (nodeInstName nd) ANode++instance Defines NodeDecl where+ defines nd = addDef (nodeName nd) ANode++instance Defines LocalDecl where+ defines ld =+ case ld of+ LocalVar b -> addDef (binderDefines b) AVal+ LocalConst c -> defines c++instance Defines ContractItem where+ defines ci =+ case ci of+ GhostConst d -> defines d+ GhostVar b _ -> addDef (binderDefines b) AVal+ Assume _ _ -> pure ()+ Guarantee _ _ -> pure ()+ Mode _ _ _ -> pure () -- XXX: node references?+ Import _ _ _ -> pure () -- XXX: node references++instance Defines ContractDecl where+ defines c = addDef (cdName c) AContract+++
+ Language/Lustre/Driver.hs view
@@ -0,0 +1,214 @@+-- | Process a collection of declarations all the way.+module Language.Lustre.Driver where++import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.List(foldl',sortBy)+import Data.Text(Text)+import AlexTools(sourceFrom,sourceIndex)+import Text.PrettyPrint(Doc)++import Language.Lustre.Name+import qualified Language.Lustre.AST as P+import qualified Language.Lustre.Core as C+import Language.Lustre.Monad+import Language.Lustre.Pretty(pp,vcatSep)+import Language.Lustre.Phase+import Language.Lustre.Transform.OrderDecls+import Language.Lustre.TypeCheck+import Language.Lustre.Transform.NoStatic+import Language.Lustre.Transform.NoStruct+import Language.Lustre.Transform.Inline+import Language.Lustre.Transform.ToCore+++-- | Export a given node to core.+-- Note that currently we process all declarations, even if some+-- of them are not needed to process the given module.+quickNodeToCore ::+ Maybe Text {- ^ Node to translate -} ->+ [P.TopDecl] {- ^ Source decls -} ->+ LustreM (ModelInfo, C.Node)+quickNodeToCore mb ds =+ do (info,ds1) <- quickDeclsSimp ds+ nodeToCore mb info ds1++data Env = Env+ { envNodes :: Map OrigName ModelFunInfo+ , envEnums :: EnumInfo+ }++-- | Process a bunch of declarations in preparation for translating to core.+-- This function works only on standalone declarations, not accounting+-- for a broader context.+quickDeclsSimp :: [P.TopDecl] ->+ LustreM (Env, [P.TopDecl])+quickDeclsSimp ds =+ do ds1 <- quickOrderTopDecl ds+ let enums = getEnumInfo ds1++ dumpPhase PhaseRename $ vcatSep $ map pp ds1+ ds2 <- quickCheckDecls ds1+ dumpPhase PhaseTypecheck $ vcatSep $ map pp ds2++ (csMap,ds3) <- noConst ds2+ dumpPhase PhaseNoStatic $ vcatSep $ map pp ds3++ let nosIn = NosIn+ { nosiStructs = Map.empty+ , nosiCallSites = csMap+ }+ (nosOut,ds4) <- noStruct nosIn ds3+ dumpPhase PhaseNoStruct $ vcatSep $ map pp ds4++ (rens,ds5) <- inlineCalls [] ds4+ dumpPhase PhaseInline $ vcatSep $ map pp ds5++ pure (Env { envNodes = mfiMap ds1 nosOut rens+ , envEnums = enums+ }+ , ds5)++dumpPhase :: LustrePhase -> Doc -> LustreM ()+dumpPhase ph doc =+ lustreIfDumpAfter ph $+ do let msg = show ph+ logMessage msg+ logMessage (replicate (length msg) '=')+ logMessage ""+ logMessage (show doc)+ logMessage ""++nodeToCore ::+ Maybe Text {- ^ Node to translate -} ->+ Env {- ^ Info about the environment -} ->+ [P.TopDecl] {- ^ Simplified top decls -} ->+ LustreM (ModelInfo, C.Node)+nodeToCore mb env ds =+ do nd <- findNode mb ds+ core <- evalNodeDecl (envEnums env) nd+ dumpPhase PhaseToCore (pp core)+ pure (ModelInfo { infoNodes = envNodes env+ , infoTop = identOrigName (P.nodeName nd)+ , infoEnums = envEnums env+ }+ , core)+++findNode ::+ Maybe Text {- ^ Name hint -} ->+ [P.TopDecl] {- ^ Simplified declarations -} ->+ LustreM P.NodeDecl+findNode mb ds =+ case [ nd | nd <- nodes, selected nd ] of+ [nd] -> pure nd+ [] | nd : _ <- sortBy later nodes -> pure nd+ nds -> reportError $ BadEntryPoint+ [ identOrigName (P.nodeName nd) | nd <- nds ]+ where+ nodes = [ nd | P.DeclareNode nd <- ds ]++ selected =+ case mb of+ Nothing -> hasMain+ Just t -> \nd -> identText (P.nodeName nd) == t++ hasMain nd+ | Just b <- P.nodeDef nd = any isMain (P.nodeEqns b)+ | otherwise = False+++ isMain eqn = case eqn of+ P.IsMain _ -> True+ _ -> False++ -- XXX: assumes all declaration in the same file.+ locId = sourceIndex . sourceFrom . identRange . P.nodeName+ later x y = compare (locId y) (locId x)++--------------------------------------------------------------------------------+-- | Information for mapping traces back to source Lustre+data ModelInfo = ModelInfo+ { infoNodes :: Map OrigName ModelFunInfo+ -- ^ Translation information for nodes.++ , infoTop :: OrigName+ -- ^ Name for top node++ , infoEnums :: !EnumInfo+ -- ^ Information about enums+ }++++--------------------------------------------------------------------------------++++-- | Collected information about a translated node.+-- Mostly stuff we need to map from Core models, back to original source.+data ModelFunInfo = ModelFunInfo+ { mfiCallSites :: Map CallSiteId [OrigName]+ {- ^ For each call site, rememebr the identifiers keeping the results+ of the call. -}++ , mfiStructs :: Map OrigName (StructData OrigName)+ {- ^ Identifiers of strucutred types (e.g., structs, arrays) are+ "exploded" into multiple variables. This mapping remembers how+ we did that: the key is a value of a strucutred type, and+ the entry in the map is the value for it -}++ , mfiInlined :: Map [OrigName] (OrigName, Renaming)+ {- ^ Information about what we called, and how things got renamed+ when we inlined things.+ For each call site (identified by its return values),+ we have a map from the original names in the function, to the+ new names used in the inlined version. -}++ , mfiSource :: P.NodeDecl+ -- ^ The renamed, but otherwise unsimplified code for the node+ -- that implemnets this function. See 'nodeSourceMap' for details.+ }++++mfiMap :: [P.TopDecl] -> NosOut -> AllRenamings -> Map OrigName ModelFunInfo+mfiMap ordDs nos rens =+ Map.fromList $ map build+ $ Set.toList+ $ Set.unions [ Map.keysSet (nosoCallSites nos)+ , Map.keysSet (nosoExpanded nos)+ , Map.keysSet rens ]+ where+ build k = (k, ModelFunInfo { mfiCallSites = lkpMap k (nosoCallSites nos)+ , mfiStructs = lkpMap k (nosoExpanded nos)+ , mfiInlined = lkpMap k rens+ , mfiSource = srcMap Map.! k+ })++ lkpMap = Map.findWithDefault Map.empty++ srcMap = nodeSourceMap ordDs++++-- | Compute a mapping from node names to the actual source that implements+-- them. For example, consider the declaration @f = g <<3>>@. If we want to+-- see how @f@ works, we should really look for the code for @g@.+nodeSourceMap :: [P.TopDecl] -> Map OrigName P.NodeDecl+nodeSourceMap = foldl' add Map.empty+ where+ add mp tde =+ case tde of+ P.DeclareNode nd -> Map.insert (identOrigName (P.nodeName nd)) nd mp+ P.DeclareNodeInst nid ->+ case P.nodeInstDef nid of+ P.NodeInst (P.CallUser f) _+ | Just nd <- Map.lookup (nameOrigName f) mp ->+ Map.insert (identOrigName (P.nodeInstName nid)) nd mp+ _ -> mp+ P.DeclareType {} -> mp+ P.DeclareConst {} -> mp++
+ Language/Lustre/Error.hs view
@@ -0,0 +1,99 @@+{-# Language OverloadedStrings #-}+module Language.Lustre.Error where++import Text.PrettyPrint hiding ((<>))+import qualified Text.PrettyPrint as PP+import Control.Exception++import Language.Lustre.AST(SourceRange(..),range)+import Language.Lustre.Name+import Language.Lustre.Pretty+++data LustreError =+ ResolverError ResolverError+ | TCError [SourceRange] Doc+ | BadEntryPoint [ OrigName ]+ deriving Show++instance Exception LustreError++data LustreWarning =+ ResolverWarning ResolverWarning+++-- | Various things that can go wrong when resolving names.+data ResolverError =+ InvalidConstantExpression String+ | UndefinedName Name+ | AmbiguousName Name OrigName OrigName+ | RepeatedDefinitions [OrigName]+ | BadRecursiveDefs [OrigName]+ deriving Show++-- | Potential problems, but not fatal.+data ResolverWarning =+ Shadows OrigName OrigName++--------------------------------------------------------------------------------++instance Pretty LustreError where+ ppPrec n err =+ case err of+ ResolverError re -> ppPrec n re+ TCError locs d -> case locs of+ [] -> d+ l : _ -> pp l PP.<> colon <+> d+ BadEntryPoint xs ->+ case xs of+ [] -> "Failed to find an entry point, please use %MAIN"+ _ -> nested "Found multiple entry points:"+ (vcat (map pp xs))++instance Pretty LustreWarning where+ ppPrec n warn =+ case warn of+ ResolverWarning rw -> ppPrec n rw++instance Pretty ResolverError where+ ppPrec _ err =+ case err of++ InvalidConstantExpression x ->+ "Construct" <+> backticks (text x) <+>+ "may not appear in constant expressions."++ UndefinedName x ->+ located (range x)+ [ "The name" <+> backticks (pp x) <+> "is undefined." ]++ AmbiguousName x a b ->+ located (range x)+ [ "The name" <+> backticks (pp x) <+> "is ambiguous."+ , block "It may refer to:" [ppOrig a, ppOrig b]+ ]++ RepeatedDefinitions xs ->+ block "Multiple declaratoins for the same name:" (map ppOrig xs)++ BadRecursiveDefs xs ->+ block "Invalid recursive declarations:" (map ppOrig xs)++ where+ block x ys = nested x (bullets ys)+ located r xs = block ("At" <+> pp r) xs++ppOrig :: OrigName -> Doc+ppOrig x = backticks (pp x) PP.<> ","+ <+> "defined at" <+> pp (identRange (rnIdent x))+ <+> parens ("unqiue" <+> pp (rnUID x))+++instance Pretty ResolverWarning where+ ppPrec _ warn =+ case warn of+ Shadows x y ->+ ppOrig x <+> "shadows" <+> ppOrig y+++
+ Language/Lustre/ModelState.hs view
@@ -0,0 +1,205 @@+module Language.Lustre.ModelState+ ( -- * Locations and Navigation+ Loc, locTop, ModelInfo, locCalls, enterCall, exitCall, locName,++ -- * Call sites+ CallSiteId, callSiteName,++ -- * Accessing Variables+ S, Vars(..), lookupVars, locVars,+ -- * Names+ CoreValue, SourceValue,+ ) where++import Data.Map (Map)+import qualified Data.Map as Map++import Language.Lustre.Name+import qualified Language.Lustre.AST as P+import Language.Lustre.Core(CoreName,coreNameFromOrig)+import Language.Lustre.Transform.NoStatic(CallSiteId,callSiteName)+import Language.Lustre.Transform.NoStruct(StructData(..))+import Language.Lustre.Transform.Inline(Renaming(..))+import Language.Lustre.Transform.ToCore(enumFromVal)+import Language.Lustre.Driver(ModelInfo(..), ModelFunInfo(..))+import qualified Language.Lustre.Semantics.Core as L+import qualified Language.Lustre.Semantics.Value as V+import Language.Lustre.Panic(panic)++-- | A state for a core lustre program.+type S = Map CoreName CoreValue+type CoreValue = L.Value -- ^ Value for a core expression+type SourceValue = V.Value -- ^ Value for full Lustre++--------------------------------------------------------------------------------++-- | A 'Loc' is an instantiation of a function with specific arguments.+-- It helps is traverse the call tree at a specific state in the system.+data Loc = Loc+ { lModel :: ModelInfo+ {- ^ Read only. For convenience we pass around the whole model info,+ so that we can access global thing (e.g., the lustre to core variable+ mapping) -}++ , lFunInfo :: ModelFunInfo+ {- ^ Information about the translation of the specific function we are in -}++ , lSubst :: Map OrigName OrigName+ {- ^ Accumulated renamings for variables resulting from Lustre-Lustre+ translations -}++ , lVars :: Vars (OrigName, P.Type)+ -- ^ These are the variables we are observing.++ , lAbove :: Maybe Loc+ -- ^ Locations on the current call path. This is for navigation,+ -- so we can go back to our parent.++ , lRange :: P.SourceRange+ -- ^ Location in the source code for this node+ }++-- | Get the name of node corresponding to the current location.+locName :: Loc -> OrigName+locName = identOrigName . P.nodeName . mfiSource . lFunInfo++instance P.HasRange Loc where+ range = lRange++-- | The location corresponding to the main function being verified.+locTop :: ModelInfo -> Maybe Loc+locTop mi =+ do let top = infoTop mi+ fi <- Map.lookup top (infoNodes mi)+ let nd = mfiSource fi+ pure Loc { lModel = mi+ , lFunInfo = fi+ , lSubst = Map.empty+ , lVars = nodeVars nd+ , lAbove = Nothing+ , lRange = P.range nd+ }++-- | Given a location and a call site in it, get the location corresponding+-- to the given call.+enterCall :: Loc -> CallSiteId -> Maybe Loc+enterCall l cs =+ do let mf = lFunInfo l+ xs <- Map.lookup cs (mfiCallSites mf)+ (f,ren) <- Map.lookup xs (mfiInlined mf)+ let su = renVarMap ren+ let mi = lModel l+ fi <- Map.lookup f (infoNodes mi)+ let nd = mfiSource fi+ let vars = nodeVars nd+ su1 = fmap (\i -> Map.findWithDefault i i (lSubst l)) su+ pure l { lFunInfo = fi+ , lSubst = su1+ , lVars = vars+ , lAbove = Just l+ , lRange = P.range nd+ }++-- | What are the callsites avaialable at a location.+locCalls :: Loc -> [CallSiteId]+locCalls = Map.keys . mfiCallSites . lFunInfo++-- | Got back to the parent of a location.+exitCall :: Loc -> Maybe Loc+exitCall = lAbove+++--------------------------------------------------------------------------------++-- | The variables at this location.+locVars :: Loc -> Vars (OrigName, P.Type)+locVars = lVars++-- | Get the values for all varialbes in a location.+lookupVars :: Loc -> S -> Vars (OrigName, P.Type, Maybe SourceValue)+lookupVars l s = fmap lkp (lVars l)+ where lkp (i,t) = (i, t, lookupVar l s t i)+++-- | Get the value for a variable in a location, in a specific state.+lookupVar :: Loc -> S -> P.Type -> OrigName -> Maybe SourceValue+lookupVar l s t i0 =+ case Map.lookup i (mfiStructs (lFunInfo l)) of+ Just si ->+ do si1 <- traverse (lookupVar l s t) si+ pure (restruct si1)+ Nothing ->+ do v1 <- Map.lookup (coreNameFromOrig i) s+ reval l t v1+ where+ i = Map.findWithDefault i0 i0 (lSubst l)+++-- | Change representations of values.+reval :: Loc -> P.Type -> L.Value -> Maybe SourceValue+reval loc t val =+ case val of+ L.VInt n+ | P.NamedType tn <- t+ , let tno = nameOrigName tn+ , Just c <- Map.lookup (tno,n) (enumFromVal (infoEnums (lModel loc)))+ -> Just (V.VEnum tno c)+ | otherwise -> Just (V.VInt n)+ L.VBool n -> Just (V.VBool n)+ L.VReal n -> Just (V.VReal n)+ L.VNil -> Nothing+++-- | Change of representations.+restruct :: StructData SourceValue -> SourceValue+restruct str =+ case str of+ SLeaf a -> a+ SArray xs -> V.VArray (map restruct xs)+ SStruct x vs -> V.VStruct x (fmap (fmap restruct) vs)+ STuple {} -> panic "restruct" ["Unexpected tuple"]++++--------------------------------------------------------------------------------+-- | This is what we report+data Vars i = Vars+ { vIns :: [i]+ , vLocs :: [i]+ , vOuts :: [i]+ } deriving Show++instance Functor Vars where+ fmap f vs = Vars { vIns = fmap f (vIns vs)+ , vLocs = fmap f (vLocs vs)+ , vOuts = fmap f (vOuts vs)+ }++instance Foldable Vars where+ foldMap f vs = mconcat [ foldMap f (vIns vs)+ , foldMap f (vLocs vs)+ , foldMap f (vOuts vs)+ ]++instance Traversable Vars where+ traverse f vs = Vars <$> traverse f (vIns vs)+ <*> traverse f (vLocs vs)+ <*> traverse f (vOuts vs)+++-- | Get the variables from a node.+nodeVars :: P.NodeDecl -> Vars (OrigName, P.Type)+nodeVars nd = Vars { vIns = fromB [ b | P.InputBinder b <- P.nodeInputs prof ]+ , vLocs = fromB locs+ , vOuts = fromB (P.nodeOutputs prof)+ }+ where+ prof = P.nodeProfile nd+ locs = case P.nodeDef nd of+ Nothing -> []+ Just d -> [ b | P.LocalVar b <- P.nodeLocals d ]+ fromB bs = [ ( identOrigName (P.binderDefines b)+ , P.cType (P.binderType b)+ )+ | b <- bs ]+
+ Language/Lustre/Monad.hs view
@@ -0,0 +1,184 @@+{-# Language DataKinds, GeneralizedNewtypeDeriving #-}+{-# Language MultiParamTypeClasses #-}+-- | "Global" monad for Lustre processing.+module Language.Lustre.Monad+ ( -- * The Lustre monad+ runLustre+ , LustreConf(..)+ , LustreM++ -- ** Errors and Warnings+ , reportError+ , addWarning+ , getWarnings+ , module Language.Lustre.Error++ -- ** Access to the Name Seed+ , getNameSeed+ , setNameSeed+ , newInt++ -- ** Logging+ , setVerbose+ , logMessage+ , lustreIfDumpAfter++ -- * Name seeds+ , NameSeed+ , nextNameSeed+ , nameSeedToInt+ , invalidNameSeed+ , isValidNameSeed++ ) where+++import System.IO(Handle,hPutStrLn,hFlush)+import MonadLib+import Control.Exception(throwIO)+import Data.Set(Set)+import qualified Data.Set as Set++import Language.Lustre.Error+import Language.Lustre.Panic+import Language.Lustre.Phase++-- | A common monad for all lustre passes+newtype LustreM a = LustreM+ { unLustreM ::+ WithBase IO+ [ ReaderT GlobalLustreEnv+ , ExceptionT LustreError+ , StateT GlobalLustreState+ ] a+ } deriving (Functor,Applicative,Monad)++instance BaseM LustreM LustreM where+ inBase = id+++data GlobalLustreEnv = GlobalLustreEnv+ { luLogHandle :: !Handle+ , luDumpAfter :: !(Set LustrePhase)+ }+++-- | Generic state commong the lustre implementation+data GlobalLustreState = GlobalLustreState+ { luWarnings :: ![LustreWarning]+ , luNameSeed :: !NameSeed+ , luVerbose :: !Bool+ }++-- | An abstract type for generating names.+newtype NameSeed = NameSeed Int deriving Show+++-- | A new name seed.+nextNameSeed :: NameSeed -> NameSeed+nextNameSeed (NameSeed x) = NameSeed (x + 1)++-- | Name seed rendered as a number.+nameSeedToInt :: NameSeed -> Int+nameSeedToInt (NameSeed x) = x++-- | In a few places we have name seeds that should not be used.+-- To enforce this invariant, we use 'invalidNameSeeds', so that it+-- is fairly easy to notice if messed up.+-- (we cannot use 'error' as the NameSeed is strict)+invalidNameSeed :: Int -> NameSeed+invalidNameSeed x = if x < 0 then NameSeed x else NameSeed (negate x)++-- | Is this a valid name seed.+isValidNameSeed :: NameSeed -> Bool+isValidNameSeed (NameSeed x) = x >= 0++-- | Configuration for running Lustre computations.+data LustreConf = LustreConf+ { lustreInitialNameSeed :: Maybe NameSeed+ , lustreLogHandle :: !Handle+ , lustreDumpAfter :: !(Set LustrePhase)+ }++-- | Execute a Lustre computation.+-- May throw `LustreError`+runLustre :: LustreConf -> LustreM a -> IO a+runLustre conf m =+ do let env = GlobalLustreEnv { luLogHandle = lustreLogHandle conf+ , luDumpAfter = lustreDumpAfter conf+ }+ st = GlobalLustreState+ { luNameSeed = case lustreInitialNameSeed conf of+ Nothing -> NameSeed 0+ Just s -> s+ , luVerbose = False+ , luWarnings = []+ }+ (res,_) <- runM (unLustreM m) env st+ case res of+ Left err -> throwIO err+ Right a -> pure a++-- | Log something, if we are verbose.+logMessage :: String -> LustreM ()+logMessage msg =+ LustreM $ do verb <- luVerbose <$> get+ when verb $+ do h <- luLogHandle <$> ask+ inBase $ do hPutStrLn h msg+ hFlush h++-- | Set verbosity. 'True' means enable logging. Affect `lustreLog`.+setVerbose :: Bool -> LustreM ()+setVerbose b = LustreM $ sets_ $ \s -> s { luVerbose = b }++-- | Abort further computation with the given error.+reportError :: LustreError -> LustreM a+reportError e = LustreM (raise e)++-- | Record a warning.+addWarning :: LustreWarning -> LustreM ()+addWarning w =+ LustreM $ sets_ $ \s -> s { luWarnings = w : luWarnings s }++-- | Get the warnings collected so far.+getWarnings :: LustreM [LustreWarning]+getWarnings = LustreM $ luWarnings <$> get++-- | Get the current name seed.+getNameSeed :: LustreM NameSeed+getNameSeed = LustreM $ luNameSeed <$> get++-- | Set the current name seed to something.+setNameSeed :: NameSeed -> LustreM ()+setNameSeed newSeed =+ LustreM $ sets_ $ \s ->+ let oldSeed = luNameSeed s+ in if nameSeedToInt oldSeed > nameSeedToInt newSeed+ then panic "Language.Lustre.Monad.lustreSetSeed"+ [ "New seed is smaller than the current seed."+ , "*** Old seed: " ++ show oldSeed+ , "*** New seed: " ++ show newSeed+ ]+ else s { luNameSeed = newSeed }+++-- | Use the name see to generate a new int.+newInt :: LustreM Int+newInt =+ do seed <- getNameSeed+ unless (isValidNameSeed seed) $+ panic "newName" [ "Attempt ot generate a new name in invald context."+ , "*** Name seed hint: " ++ show seed+ ]+ setNameSeed (nextNameSeed seed)+ pure (nameSeedToInt seed)+++-- | Execute the given action---presumably for printing---only if+-- dumping after the given phase is enables.+lustreIfDumpAfter :: LustrePhase -> LustreM () -> LustreM ()+lustreIfDumpAfter ph (LustreM m) =+ LustreM $ do du <- luDumpAfter <$> ask+ when (ph `Set.member` du) m+
+ Language/Lustre/Name.hs view
@@ -0,0 +1,213 @@+module Language.Lustre.Name where++import Data.Text(Text)+import AlexTools(SourceRange(..), HasRange(..))++import Language.Lustre.Panic(panic)++{- | Just a textual name. Used to remember the user specified names of+things, as well as for things that are not quite names (e.g., field+labels) -}+data Label = Label+ { labText :: !Text+ -- ^ The label's text.++ , labRange :: !SourceRange+ -- ^ The location of the lable in the source program.+ } deriving Show+++{- | The type of unqualified names+Used when we define things and at some use sites that can only refer to+locally defined things. -}+data Ident = Ident+ { identLabel :: !Label+ , identResolved :: !(Maybe OrigName)+ } deriving Show++-- | The text associates with an identifier.+identText :: Ident -> Text+identText = labText . identLabel++-- | The location of the idnetifier in the source program.+identRange :: Ident -> SourceRange+identRange = labRange . identLabel++-- | Do something with a resolve idnetifier.+-- Panics if the identifier is not resolved.+withResolved :: (OrigName -> a) -> Ident -> a+withResolved k i = case identResolved i of+ Just info -> k info+ Nothing -> panic "withResolved"+ [ "The identifier is not resolved."+ , "*** Name: " ++ show (identText i)+ , "*** Range: " ++ show (identRange i)+ ]++-- | Access the definition site for the given resolved identifier.+identOrigName :: Ident -> OrigName+identOrigName = withResolved id++-- | Access the unique identifier of a resolved identifier.+identUID :: Ident -> Int+identUID = withResolved rnUID++-- | Access the module, if any, of a resolved identifier.+identModule :: Ident -> Maybe ModName+identModule = withResolved rnModule++-- | Get information about what sort of thing this resolved identifier+-- refers to.+identThing :: Ident -> Thing+identThing = withResolved rnThing+++-- | A possibly qualified name. Used at use sites where qualifier might be+-- OK. Mostly used to refer to types and constants in other modules.+data Name =+ Unqual Ident+ -- ^ After name resolution, the 'identResolved' field of the+ -- identifier should always be filled in.++ | Qual ModName Ident+ -- ^ Qualified name. Produced in the parser. Should not appear+ -- after name resolution, where all names should be unqualified resolved+ -- identifiers.+ deriving Show+++-- | Get the original name of a resolved name.+nameOrigName :: Name -> OrigName+nameOrigName nm =+ case nm of+ Unqual i -> identOrigName i+ Qual {} -> panic "nameOrigName"+ [ "Unexpected qualified name:"+ , "*** Name: " ++ show nm+ ]++--------------------------------------------------------------------------------+++-- | Comapred by text.+instance Eq Label where+ x == y = labText x == labText y++-- | Comapred by text.+instance Ord Label where+ compare x y = compare (labText x) (labText y)++++-- | Comapred by original name, if available, or by text otherwise.+-- Resolved and unresolved names are different.+instance Eq Ident where+ x == y = case (identResolved x, identResolved y) of+ (Just a, Just b) -> a == b+ (Nothing,Nothing) -> identText x == identText y+ _ -> False++-- | Same as 'Eq'+instance Ord Ident where+ compare i j =+ case (identResolved i, identResolved j) of+ (Just x, Just y) -> compare x y+ (Nothing, Nothing) -> compare (identText i) (identText j)++ -- This are arbitrary, and somehwat questionable.+ -- Perhaps we should panic instead?+ (Nothing, Just _) -> LT+ (Just _, Nothing) -> GT++++instance Eq Name where+ m == n = case (m,n) of+ (Unqual a, Unqual b) -> a == b+ (Qual x y, Qual p q) -> (x,y) == (p,q)+ _ -> False++instance Ord Name where+ compare m n = case (m,n) of+ (Unqual x, Unqual y) -> compare x y+ (Unqual {}, _) -> LT+ (_, Unqual {}) -> GT+ (Qual x y, Qual p q) -> compare (x,y) (p,q)+++--------------------------------------------------------------------------------+++instance HasRange Label where+ range = labRange++instance HasRange Ident where+ range = identRange++instance HasRange Name where+ range nm =+ case nm of+ Unqual i -> range i+ Qual _ i -> range i+++-- | Information about the definition of an identifier.+data OrigName = OrigName+ { rnUID :: !Int -- ^ A unique identifier+ , rnModule :: !(Maybe ModName) -- ^ Module where this is defined, if any+ , rnIdent :: !Ident -- ^ Original (unresolved) identifier at+ -- definition site. Useful for location,+ -- pragmas, etc.+ , rnThing :: !Thing -- ^ What are we+ } deriving Show++origNameToIdent :: OrigName -> Ident+origNameToIdent d = (rnIdent d) { identResolved = Just d }++origNameToName :: OrigName -> Name+origNameToName = Unqual . origNameToIdent++-- | The textual name of an original name, without module.+origNameTextName :: OrigName -> Text+origNameTextName n = identText (rnIdent n)++instance HasRange OrigName where+ range = range . rnIdent++instance Eq OrigName where+ x == y = rnUID x == rnUID y++instance Ord OrigName where+ compare x y = compare (rnUID x) (rnUID y)+++-- | The name of a module.+newtype ModName = Module Text+ deriving (Eq,Ord,Show)+++-- | What sorts of things can be defined+data Thing = AType | ANode | AContract | AConst | AVal+ deriving (Show,Eq,Ord)+++-- | Various name spaces.+data NameSpace = NSType | NSNode | NSContract | NSVal+ deriving (Show,Eq,Ord)++-- | In what namespace do things live in.+thingNS :: Thing -> NameSpace+thingNS th =+ case th of+ AType -> NSType+ ANode -> NSNode+ AContract -> NSContract+ AVal -> NSVal+ AConst -> NSVal+++++++
+ Language/Lustre/Panic.hs view
@@ -0,0 +1,16 @@+{-# Language TemplateHaskell #-}+module Language.Lustre.Panic (panic) where++import Panic hiding (panic)+import qualified Panic++data Lustre = Lustre++instance PanicComponent Lustre where+ panicComponentName _ = "Lustre"+ panicComponentIssues _ = "https://github.com/GaloisInc/lustre"+ panicComponentRevision = $useGitRevision++panic :: HasCallStack => String -> [String] -> a+panic = Panic.panic Lustre+
+ Language/Lustre/Parser.y view
@@ -0,0 +1,1138 @@+{+{-# Language OverloadedStrings #-}+module Language.Lustre.Parser+ ( parse, parseStartingAt+ , parseProgramFrom+ , parseProgramFromFileUTF8+ , parseProgramFromFileLatin1+ , program, expression+ , ParseError(..)+ , prettySourcePos, prettySourcePosLong+ , prettySourceRange, prettySourcePosLong+ ) where++import AlexTools+import Data.Semigroup+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import qualified Data.Text.Encoding as Text+import qualified Data.ByteString as BS+import Data.Semigroup ((<>))+import Control.Exception(throwIO)+import Control.Monad(foldM)++import Language.Lustre.Parser.Lexer+import Language.Lustre.Parser.Monad+import Language.Lustre.Name+import Language.Lustre.AST+import Language.Lustre.Pretty(showPP)+import Language.Lustre.Panic+}+++%tokentype { Lexeme Token }++%token++ 'package' { Lexeme { lexemeRange = $$, lexemeToken = TokKwPackage } }+ 'model' { Lexeme { lexemeRange = $$, lexemeToken = TokKwModel } }+ 'is' { Lexeme { lexemeRange = $$, lexemeToken = TokKwIs } }+ 'uses' { Lexeme { lexemeRange = $$, lexemeToken = TokKwUses } }+ 'needs' { Lexeme { lexemeRange = $$, lexemeToken = TokKwNeeds } }+ 'provides' { Lexeme { lexemeRange = $$, lexemeToken = TokKwProvides } }+ 'body' { Lexeme { lexemeRange = $$, lexemeToken = TokKwBody } }+ 'end' { Lexeme { lexemeRange = $$, lexemeToken = TokKwEnd } }++ 'if' { Lexeme { lexemeRange = $$, lexemeToken = TokKwIf } }+ 'then' { Lexeme { lexemeRange = $$, lexemeToken = TokKwThen } }+ 'else' { Lexeme { lexemeRange = $$, lexemeToken = TokKwElse } }+ 'with' { Lexeme { lexemeRange = $$, lexemeToken = TokKwWith } }+ 'merge' { Lexeme { lexemeRange = $$, lexemeToken = TokKwMerge } }++ 'and' { Lexeme { lexemeRange = $$, lexemeToken = TokKwAnd } }+ 'not' { Lexeme { lexemeRange = $$, lexemeToken = TokKwNot } }+ 'or' { Lexeme { lexemeRange = $$, lexemeToken = TokKwOr } }+ 'xor' { Lexeme { lexemeRange = $$, lexemeToken = TokKwXor } }+ 'nor' { Lexeme { lexemeRange = $$, lexemeToken = TokKwNor } }+ '#' { Lexeme { lexemeRange = $$, lexemeToken = TokHash } }+ '=>' { Lexeme { lexemeRange = $$, lexemeToken = TokImplies } }++ '<' { Lexeme { lexemeRange = $$, lexemeToken = TokLt } }+ '<=' { Lexeme { lexemeRange = $$, lexemeToken = TokLeq } }+ '=' { Lexeme { lexemeRange = $$, lexemeToken = TokEq } }+ ':=' { Lexeme { lexemeRange = $$, lexemeToken = TokColonEq } }+ '>=' { Lexeme { lexemeRange = $$, lexemeToken = TokGeq } }+ '>' { Lexeme { lexemeRange = $$, lexemeToken = TokGt } }+ '<>' { Lexeme { lexemeRange = $$, lexemeToken = TokNotEq } }++ 'extern' { Lexeme { lexemeRange = $$, lexemeToken = TokKwExtern } }+ 'imported' { Lexeme { lexemeRange = $$, lexemeToken = TokKwImported } }+ 'unsafe' { Lexeme { lexemeRange = $$, lexemeToken = TokKwUnsafe } }+ 'node' { Lexeme { lexemeRange = $$, lexemeToken = TokKwNode } }+ 'function' { Lexeme { lexemeRange = $$, lexemeToken = TokKwFunction } }+ 'returns' { Lexeme { lexemeRange = $$, lexemeToken = TokKwReturns } }++ 'type' { Lexeme { lexemeRange = $$, lexemeToken = TokKwType } }+ 'const' { Lexeme { lexemeRange = $$, lexemeToken = TokKwConst } }+ 'var' { Lexeme { lexemeRange = $$, lexemeToken = TokKwVar } }+ 'struct' { Lexeme { lexemeRange = $$, lexemeToken = TokKwStruct } }+ 'enum' { Lexeme { lexemeRange = $$, lexemeToken = TokKwEnum } }++ 'contract' { Lexeme { lexemeRange = $$, lexemeToken = TokKwContract } }+ 'import' { Lexeme { lexemeRange = $$, lexemeToken = TokKwImport } }+ 'assert' { Lexeme { lexemeRange = $$, lexemeToken = TokKwAssert } }+ 'assume' { Lexeme { lexemeRange = $$, lexemeToken = TokKwAssume } }+ 'guarantee' { Lexeme { lexemeRange = $$, lexemeToken = TokKwGuarantee } }+ 'mode' { Lexeme { lexemeRange = $$, lexemeToken = TokKwMode } }+ 'require' { Lexeme { lexemeRange = $$, lexemeToken = TokKwRequire } }+ 'ensure' { Lexeme { lexemeRange = $$, lexemeToken = TokKwEnsure } }+ '--%PROPERTY' { Lexeme { lexemeRange = $$, lexemeToken = TokPragmaProperty } }+ '--%MAIN' { Lexeme { lexemeRange = $$, lexemeToken = TokPragmaMain } }+ '--%IVC' { Lexeme { lexemeRange = $$, lexemeToken = TokPragmaIVC } }+ '--%REALIZABLE' { Lexeme { lexemeRange = $$,+ lexemeToken = TokPragmaRealizable } }++ 'when' { Lexeme { lexemeRange = $$, lexemeToken = TokKwWhen } }+ 'current' { Lexeme { lexemeRange = $$, lexemeToken = TokKwCurrent } }+ 'currentWith'{ Lexeme { lexemeRange = $$, lexemeToken = TokKwCurrentWith } }+ 'condact' { Lexeme { lexemeRange = $$, lexemeToken = TokKwCondact } }+ 'callWhen' { Lexeme { lexemeRange = $$, lexemeToken = TokKwCallWhen } }+ 'pre' { Lexeme { lexemeRange = $$, lexemeToken = TokKwPre } }+ 'fby' { Lexeme { lexemeRange = $$, lexemeToken = TokKwFby } }+ '->' { Lexeme { lexemeRange = $$, lexemeToken = TokRightArrow } }++ 'div' { Lexeme { lexemeRange = $$, lexemeToken = TokKwDiv } }+ 'mod' { Lexeme { lexemeRange = $$, lexemeToken = TokKwMod } }+ '+' { Lexeme { lexemeRange = $$, lexemeToken = TokPlus } }+ '-' { Lexeme { lexemeRange = $$, lexemeToken = TokMinus } }+ '*' { Lexeme { lexemeRange = $$, lexemeToken = TokStar } }+ '**' { Lexeme { lexemeRange = $$, lexemeToken = TokStarStar } }+ '/' { Lexeme { lexemeRange = $$, lexemeToken = TokDiv } }+ 'floor' { Lexeme { lexemeRange = $$, lexemeToken = TokKwFloor } }+++ 'step' { Lexeme { lexemeRange = $$, lexemeToken = TokKwStep } }+ '|' { Lexeme { lexemeRange = $$, lexemeToken = TokBar } }+ '^' { Lexeme { lexemeRange = $$, lexemeToken = TokHat } }+ '..' { Lexeme { lexemeRange = $$, lexemeToken = TokDotDot } }++ 'int' { Lexeme { lexemeRange = $$, lexemeToken = TokKwInt } }+ 'real' { Lexeme { lexemeRange = $$, lexemeToken = TokKwReal } }+ 'bool' { Lexeme { lexemeRange = $$, lexemeToken = TokKwBool } }+ 'subrange' { Lexeme { lexemeRange = $$, lexemeToken = TokKwSubrange } }+ 'of' { Lexeme { lexemeRange = $$, lexemeToken = TokKwOf } }+++ ':' { Lexeme { lexemeRange = $$, lexemeToken = TokColon } }+ ',' { Lexeme { lexemeRange = $$, lexemeToken = TokComma } }+ ';' { Lexeme { lexemeRange = $$, lexemeToken = TokSemi } }+ '.' { Lexeme { lexemeRange = $$, lexemeToken = TokDot } }+++ 'let' { Lexeme { lexemeRange = $$, lexemeToken = TokKwLet } }+ 'tel' { Lexeme { lexemeRange = $$, lexemeToken = TokKwTel } }+ '(' { Lexeme { lexemeRange = $$, lexemeToken = TokOpenParen } }+ ')' { Lexeme { lexemeRange = $$, lexemeToken = TokCloseParen } }+ '<<' { Lexeme { lexemeRange = $$, lexemeToken = TokOpenTT } }+ '>>' { Lexeme { lexemeRange = $$, lexemeToken = TokCloseTT } }+ '[' { Lexeme { lexemeRange = $$, lexemeToken = TokOpenBracket } }+ ']' { Lexeme { lexemeRange = $$, lexemeToken = TokCloseBracket } }+ '{' { Lexeme { lexemeRange = $$, lexemeToken = TokOpenBrace } }+ '}' { Lexeme { lexemeRange = $$, lexemeToken = TokCloseBrace } }++ '%' { Lexeme { lexemeRange = $$, lexemeToken = TokMod } }++ '/*@contract'+ { Lexeme { lexemeRange = $$, lexemeToken = TokStartSlashCommentContract } }+ '*/' { Lexeme { lexemeRange = $$, lexemeToken = TokEndSlashComment } }+ '(*@contract'+ { Lexeme { lexemeRange = $$, lexemeToken = TokStartParenCommentContract } }+ '*)' { Lexeme { lexemeRange = $$, lexemeToken = TokEndParenComment } }+++ IDENT { $$@Lexeme { lexemeToken = TokIdent {} } }+ QIDENT { $$@Lexeme { lexemeToken = TokQualIdent {} } }+ INT { $$@Lexeme { lexemeToken = TokInt {} } }+ REAL { $$@Lexeme { lexemeToken = TokReal {} } }+ BOOL { $$@Lexeme { lexemeToken = TokBool {} } }++%name program program+%name package packDecl+%name model modelDecl+%name expression expression++%lexer { happyGetToken } { Lexeme { lexemeToken = TokEOF } }+%monad { Parser }++%left 'else'+%left '|'+%nonassoc '->'+%right '=>'+%left 'or' 'xor'+%left 'and'+%nonassoc '<' '<=' '=' '>=' '>' '<>'+%nonassoc 'not'+%left '+' '-'+%left '*' '/' '%' 'mod' 'div'+%left '**'+%nonassoc 'when'+%nonassoc 'int' 'real' 'floor'+%nonassoc UMINUS 'pre' 'current'+%left '^' '.'+%right '[' '{'+%right 'fby'+++%%++program :: { Program }+ : packBody { ProgramDecls $1 }+ | ListOf1(packTop) { ProgramPacks $1 }++packTop :: { PackDecl }+ : packDecl { PackDecl $1 }+ | modelDecl { PackDecl $1 }+ | 'package' ident eq_is ident '(' SepBy1(staticArgSep,staticNamedArg) ')' ';'+ { PackInst $2 $4 $6 }+++eq_is :: { SourceRange }+ : '=' { $1 }+ | 'is' { $1 }+++-- Packages --------------------------------------------------------------------++packDecl+ : 'package' ident packUses packProvides 'body' packBody 'end'+ { Package { packageName = $2+ , packageUses = $3+ , packageParams = []+ , packageProvides = $4+ , packageBody = $6+ , packageRange = $1 <-> $7+ }+ }++packUses :: { [Ident] }+ : 'uses' SepBy1(',',ident) ';' { $2 }+ | {- empty -} { [] }++packProvides :: { [PackageProvides] }+ : 'provides' EndBy1(';',packProvide) { $2 }+ | {- empty -} { [] }++packProvide :: { PackageProvides }+ : 'const' ident ':' type Opt(provideDef) { ProvidesConst $2 $4 $5 }+ | 'type' typeDecl { ProvidesType $2 }+ | Perhaps('unsafe') nodeType ident staticParams nodeProfile+ { ProvidesNode+ NodeDecl { nodeExtern = False+ , nodeSafety = isUnsafe $1+ , nodeType = thing $2+ , nodeName = $3+ , nodeStaticInputs = $4+ , nodeProfile = thing $5+ , nodeDef = Nothing+ , nodeRange = optR $1 $2 <-> $5+ } }++provideDef :: { Expression }+ : '=' expression { $2 }+++packBody :: { [TopDecl] }+ : ListOf1(topDecl) { concat $1 }+++-- Models ----------------------------------------------------------------------++modelDecl :: { Package }+ : 'model' ident packUses 'needs' EndBy1(';',staticParam) packProvides+ 'body' packBody 'end'+ { Package { packageName = $2+ , packageUses = $3+ , packageParams = $5+ , packageProvides = $6+ , packageBody = $8+ , packageRange = $1 <-> $9+ }+ }+++++--------------------------------------------------------------------------------++topDecl :: { [TopDecl] }+ : 'const' EndBy1(';',constDef) { map DeclareConst (concat $2) }+ | 'type' EndBy1(';',typeDecl) { map DeclareType $2 }+ | extDecl { [ DeclareNode $1 ] }+ | nodeDecl { [ DeclareNode $1 ] }+ | nodeInstDecl { [ DeclareNodeInst $1 ] }+ | contractDecl { [ DeclareContract $1 ] }+++-- Constant Declarations -------------------------------------------------------++constDef :: { [ConstDef] }+ : ident ':' type { toConstDef ($1,$3) }+ | ident ',' SepBy1(',',ident) ':' type { toConstDef ($1,$3,$5) }+ | ident '=' expression { toConstDef ($1,$3) }+ | ident ':' type '=' expression { toConstDef ($1,$3,$5) }+++-- Type Declarations -----------------------------------------------------------++typeDecl :: { TypeDecl }+ : ident { toTypeDecl $1 Nothing }+ | ident '=' typeDef { toTypeDecl $1 (Just $3) }++typeDef :: { TypeDef }+ : type { IsType $1 }+ | 'enum' '{' SepBy1(',',ident) '}' { IsEnum $3 }+ | Perhaps('struct') '{' SepEndBy1(';',fieldType) '}' { IsStruct (concat $3) }+++fieldType :: { [FieldType] }+ : label ':' type '=' expression { toFieldType ($1,$3,$5) }+ | label ':' type { toFieldType ($1,$3) }+ | label ',' SepBy1(',',label) ':' type { toFieldType ($1, $3, $5) }+++-- Types -----------------------------------------------------------------------++type :: { Type }+ : builtInType { $1 }+ | name { NamedType $1 }+ | type '^' expression { at $1 $3 (ArrayType $1 $3) }+ -- jkind notation+ | type '[' expression ']' { at $1 $4 (ArrayType $1 $3) }++simpleType :: { Type }+ : builtInType { $1 }+ | simpleType '^' expression { at $1 $3 (ArrayType $1 $3) }++builtInType :: { Type }+ : 'int' { at $1 $1 IntType }+ | 'real' { at $1 $1 RealType }+ | 'bool' { at $1 $1 BoolType }+ | 'subrange'+ '[' expression ',' expression ']'+ 'of' 'int' { at $1 $8 (IntSubrange $3 $5) }+++++-- Node Declarations -----------------------------------------------------------++extDecl :: { NodeDecl }+ : Perhaps('unsafe') 'extern' nodeType ident nodeProfile Perhaps(';')+ Opt(contract)+ {% desugarContract NodeDecl+ { nodeSafety = isUnsafe $1+ , nodeExtern = True+ , nodeType = thing $3+ , nodeName = $4+ , nodeStaticInputs = [] -- XXX+ , nodeProfile = thing $5+ , nodeDef = Nothing+ , nodeRange = optR $1 $2 <-> optR $6 $5+ , nodeContract = $7+ }+ }++-- We treat 'imported' the same as 'extern'. Hopefully that's the intention.+extDecl :: { NodeDecl }+ : Perhaps('unsafe') nodeType 'imported' ident nodeProfile Perhaps(';')+ Opt(contract)+ {% desugarContract NodeDecl+ { nodeSafety = isUnsafe $1+ , nodeExtern = True+ , nodeType = thing $2+ , nodeName = $4+ , nodeStaticInputs = [] -- XXX+ , nodeProfile = thing $5+ , nodeDef = Nothing+ , nodeRange = optR $1 $2 <-> optR $6 $5+ , nodeContract = $7+ }+ }+++++nodeDecl :: { NodeDecl }+ : Perhaps('unsafe') nodeType ident staticParams nodeProfile Perhaps(';')+ Opt(contract)+ localDecls body Perhaps(';')+ {% desugarContract NodeDecl+ { nodeSafety = isUnsafe $1+ , nodeExtern = False+ , nodeType = thing $2+ , nodeName = $3+ , nodeStaticInputs = $4+ , nodeProfile = thing $5+ , nodeContract = $7+ , nodeDef = Just NodeBody { nodeLocals = $8, nodeEqns = thing $9 }+ , nodeRange = optR $1 $2 <-> optR $10 $9+ }+ }++contractDecl :: { ContractDecl }+ : 'contract' ident nodeProfile Perhaps(';')+ 'let' ListOf1(contractItem) 'tel'+ { ContractDecl+ { cdName = $2+ , cdProfile = thing $3+ , cdItems = $6+ , cdRange = $1 <-> $7+ }+ }++contract :: { Contract }+ : '/*@contract' ListOf1(contractItem) '*/' { mkContract $1 $2 $3 }+ | '(*@contract' ListOf1(contractItem) '*)' { mkContract $1 $2 $3 }++contractItem :: { ContractItem }+ : 'const' ident '=' expression Perhaps(';') { GhostConst+ (toConstDef1 ($2,$4)) }+ | 'const' ident ':' type+ '=' expression Perhaps(';') { GhostConst+ (toConstDef1 ($2,$4,$6)) }+ | 'var' ident ':' type+ '=' expression Perhaps(';') { GhostVar (simpBinder $2 $4) $6 }+ | 'assume' expression Perhaps(';') { Assume (propName $1 $2) $2 }+ | 'guarantee' expression Perhaps(';') { Guarantee (propName $1 $2) $2 }+ | 'mode' ident '(' ListOf(require)+ ListOf(ensure)+ ')' Perhaps(';') { Mode $2 $4 $5 }+ | 'import' ident '(' exprList ')'+ 'returns' '(' exprList ')' Perhaps(';') { Import $2 $4 $8 }++require :: { Expression }+ : 'require' expression Perhaps(';') { $2 }++ensure :: { Expression }+ : 'ensure' expression Perhaps(';') { $2}++nodeInstDecl :: { NodeInstDecl }+ : Perhaps('unsafe') nodeType ident staticParams Opt(nodeProfile)+ '=' effNode Perhaps(';')+ { NodeInstDecl+ { nodeInstSafety = isUnsafe $1+ , nodeInstType = thing $2+ , nodeInstName = $3+ , nodeInstStaticInputs = $4+ , nodeInstProfile = thing `fmap` $5+ , nodeInstDef = $7+ }+ }+++nodeProfile :: { Located NodeProfile }+ : params(inputParam) 'returns' params(varDecl) { mkNodeProfile $1 $3 }++nodeType :: { Located NodeType }+ : 'node' { lat $1 Node }+ | 'function' { lat $1 Function }++staticParams :: { [StaticParam] }+ : {- empty -} { [] }+ | '<<' SepBy1(';',staticParam) '>>' { $2 }++-- Description of a static parameter (i.e., this is the formal parameter)+staticParam :: { StaticParam }+ : 'type' ident { TypeParam $2 }+ | 'const' ident ':' type { ConstParam $2 $4 }+ | Perhaps('unsafe')+ nodeType+ ident nodeProfile { NodeParam (isUnsafe $1) (thing $2) $3+ (thing $4) }++localDecls :: { [LocalDecl] }+ : {- empty -} { [] }+ | ListOf1(localDecl) { concat $1 }++localDecl :: { [LocalDecl] }+ : 'var' EndBy1(';',varDecl) { map LocalVar (concat $2) }+ | 'const' EndBy1(';',constDef) { map LocalConst (concat $2) }++body :: { Located [Equation] }+ : 'let' ListOf1(equation) 'tel' { lat ($1 <-> $3) $2 }++equation :: { Equation }+ : 'assert' expression ';' { Assert (propName $1 $2)+ AssertPre $2 }+ | '--%PROPERTY' expression ';' { Property (propName $1 $2) $2 }+ | '--%MAIN' opt_semi { IsMain $1 }+ | '--%IVC' SepBy1(',',ident) ';' { IVC $2 }+ | '--%REALIZABLE' SepBy1(',',ident) ';' { Realizable $2 }+ | SepBy1(',',LHS) '=' expression ';' { Define $1 $3 }+ | '(' SepBy1(',',LHS) ')' '=' expression ';' { Define $2 $5 }+ | '(' ')' '=' expression ';' { Define [] $4 }++opt_semi :: { () }+ : {- empty -} { () }+ | ';' { () }++LHS :: { LHS Expression }+ : ident { LVar $1 }+ | LHS '.' label { LSelect $1 (SelectField $3) }+ | LHS '[' arraySel ']' { LSelect $1 $3 }+++-- Variable Declarations -------------------------------------------------------++params(par) :: { Located par }+ : '(' ')' { lat ($1 <-> $2) [] }+ | '(' SepEndBy1(';',par) ')' { lat ($1 <-> $3) (concat $2) }++inputParam :: { [InputBinder] }+ : varDecl { map InputBinder $1 }+ | 'const' typedIdents { [ InputConst i (snd $2) | i <- fst $2 ] }++varDecl :: { [Binder] }+ : typedIdents { toVarDeclBase $1 }+ | typedIdents 'when' clockExpr { toVarDecl $1 $3 }+ | '(' typedIdents ')' 'when' clockExpr { toVarDecl $2 $5 }++typedIdents :: { ( [Ident], Type ) }+ : SepBy1(',', ident) ':' type { ($1, $3) }++++-- Expressions -----------------------------------------------------------------++expression :: { Expression }+ : INT { toLit $1 }+ | REAL { toLit $1 }+ | BOOL { toLit $1 }++ | name { Var $1 }++ | 'not' expression { toE1 Not $1 $2 }+ | '-' expression %prec UMINUS { toE1 Neg $1 $2 }+ | 'pre' expression { toE1 Pre $1 $2 }+ | 'current' expression { toE1 Current $1 $2 }+ | 'int' expression { toE1 IntCast $1 $2 }+ | 'real' expression { toE1 RealCast $1 $2 }+ | 'floor' expression { toE1 FloorCast $1 $2 }++ | expression 'when' clockExpr { $1 `When` $3 }+ | expression 'fby' expression { toE2 $1 $2 Fby $3 }+ | expression '->' expression { toE2 $1 $2 FbyArr $3 }+ | expression 'and' expression { toE2 $1 $2 And $3 }+ | expression 'or' expression { toE2 $1 $2 Or $3 }+ | expression 'xor' expression { toE2 $1 $2 Xor $3 }+ | expression '=>' expression { toE2 $1 $2 Implies $3 }+ | expression '=' expression { toE2 $1 $2 Eq $3 }+ | expression '<>' expression { toE2 $1 $2 Neq $3 }+ | expression '<' expression { toE2 $1 $2 Lt $3 }+ | expression '<=' expression { toE2 $1 $2 Leq $3 }+ | expression '>' expression { toE2 $1 $2 Gt $3 }+ | expression '>=' expression { toE2 $1 $2 Geq $3 }+ | expression 'div' expression { toE2 $1 $2 Div $3 }+ | expression 'mod' expression { toE2 $1 $2 Mod $3 }+ | expression '-' expression { toE2 $1 $2 Sub $3 }+ | expression '+' expression { toE2 $1 $2 Add $3 }+ | expression '/' expression { toE2 $1 $2 Div $3 }+ | expression '*' expression { toE2 $1 $2 Mul $3 }+ | expression '**' expression { toE2 $1 $2 Power $3 }++ | expression '^' expression { toE2 $1 $2 Replicate $3 }+ | expression '|' expression { toE2 $1 $2 Concat $3 }++ | 'if' expression+ 'then' expression+ 'else' expression { toITE $1 $2 $4 $6 }++ | 'with' expression+ 'then' expression+ 'else' expression { at $1 $6 (WithThenElse $2 $4 $6) }++ | 'merge' ident ListOf1(mergeCase) { toMerge $1 $2 $3 }++ | '#' '(' exprList ')' { toEN AtMostOne $1 $4 $3 }+ | 'nor' '(' exprList ')' { toEN Nor $1 $4 $3 }++ | '[' exprList ']' { at $1 $3 (Array $2) }++ | expression '[' arraySel ']' { at $1 $4 (Select $1 $3) }+ | expression '.' label { at $1 $3 (Select $1 (SelectField $3))}+++ | 'currentWith' '(' expression ',' expression ')'+ { at $1 $6 (eOp2 $1 CurrentWith $3 $5 Nothing) }+ | 'callWhen' '(' clockExpr ',' expression ')'+ {% mkCallWhen $1 $6 $3 $5 }++ | effNode '(' exprList ')' { at $1 $4 (Call $1 $3 BaseClock Nothing) }++ | 'condact' '(' clockExpr ',' expression ',' expression ')'+ {% mkCondact $1 $8 $3 $5 (Just $7)}+ | 'condact' '(' clockExpr ',' expression ')'+ {% mkCondact $1 $6 $3 $5 Nothing }+ | 'condact' '(' BOOL',' expression ',' expression ')'+ { mkConstCondact $3 $5 $7 }+ | record { $1 }+ | tuple { $1 }+++tuple :: { Expression }+ : '(' exprList ')' { at $1 $3 (tuple $2) }++record :: { Expression }+ : expression '{' '}' {% mkStruct $1 $3 [] }+ | expression '{' SepEndBy1(';',field) '}' {% mkStruct $1 $4 $3 }+ | expression '{' name 'with' SepEndBy1(';',field) '}'+ {% mkStructU $1 $6 $3 $5 }+ | expression '{' updFiled '}' { at $1 $4 (UpdateStruct Nothing $1 [$3])}++++++mergeCase :: { (SourceRange, MergeCase Expression) }+ : '(' mergePat '->' expression ')' { ($1 <-> $5, MergeCase $2 $4) }++mergePat :: { Expression }+ : name { Var $1 }+ | BOOL { toLit $1 }++simpExpr :: { Expression }+ : INT { toLit $1 }+ | REAL { toLit $1 }+ | BOOL { toLit $1 }+ | name { Var $1 }+ | 'not' simpExpr { toE1 Not $1 $2 }+ | '-' simpExpr %prec UMINUS { toE1 Neg $1 $2 }++ | simpExpr 'and' simpExpr { toE2 $1 $2 And $3 }+ | simpExpr 'or' simpExpr { toE2 $1 $2 Or $3 }+ | simpExpr 'xor' simpExpr { toE2 $1 $2 Xor $3 }+ | simpExpr '=>' simpExpr { toE2 $1 $2 Implies $3 }+ | simpExpr '=' simpExpr { toE2 $1 $2 Eq $3 }+ | simpExpr '<>' simpExpr { toE2 $1 $2 Neq $3 }+ | simpExpr '<' simpExpr { toE2 $1 $2 Lt $3 }+ | simpExpr '<=' simpExpr { toE2 $1 $2 Leq $3 }+ | simpExpr '>' simpExpr { toE2 $1 $2 Gt $3 }+ | simpExpr '>=' simpExpr { toE2 $1 $2 Geq $3 }+ | simpExpr 'div' simpExpr { toE2 $1 $2 Div $3 }+ | simpExpr 'mod' simpExpr { toE2 $1 $2 Mod $3 }+ | simpExpr '-' simpExpr { toE2 $1 $2 Sub $3 }+ | simpExpr '+' simpExpr { toE2 $1 $2 Add $3 }+ | simpExpr '/' simpExpr { toE2 $1 $2 Div $3 }+ | simpExpr '*' simpExpr { toE2 $1 $2 Mul $3 }+ | simpExpr '**' simpExpr { toE2 $1 $2 Power $3 }++ | 'if' simpExpr+ 'then' simpExpr+ 'else' simpExpr { toITE $1 $2 $4 $6 }++ | '(' ')' { at $1 $2 (Tuple []) }+ | '(' simpExpr ')' { at $1 $3 $2 }+ | '(' simpExpr ',' SepBy1(',',simpExpr) ')' { at $1 $3 (Tuple ($2 : $4)) }+++field :: { Field Expression }+ : label '=' expression { Field $1 $3 }++updFiled :: { Field Expression }+ : label ':=' expression { Field $1 $3 }++clockExpr :: { ClockExpr }+ : name '(' ident ')' { WhenClock ($1 <-> $4) (Var $1) $3 }+ | ident { WhenClock (range $1) (Lit (Bool True)) $1 }+ | 'not' ident { WhenClock ($1 <-> $2) (Lit (Bool False)) $2 }+ | 'not' '(' ident ')' { WhenClock ($1 <-> $4) (Lit (Bool False)) $3 }++arraySel :: { Selector Expression }+ : expression { SelectElement $1 }+ | arraySlice { SelectSlice $1 }++arraySlice :: { ArraySlice Expression }+ : expression '..' expression Opt(step) { ArraySlice $1 $3 $4 }++step :: { Expression }+ : 'step' expression { $2 }++exprList :: { [Expression] }+ : SepBy1(',',expression) { $1 }+ | {- empty -} { [] }++effNode :: { NodeInst }+ : name { toNodeInst $1 [] }+ | name '<<' SepBy1(staticArgSep,staticArg) '>>' { toNodeInst $1 $3 }+++-- Static Arguments ------------------------------------------------------------+-- The specific value for a static parameter.++staticArgSep :: { () }+ : ';' { () }+ | ',' { () }++staticArg :: { StaticArg }+ : staticArgGen(noName) { snd $1 }++noName :: { () }+ : {- empty -} { () }+++staticNamedArg :: { (Ident, StaticArg) }+ : staticArgGen(withName) { $1 }++withName :: { Ident }+ : ident '=' { $1 }++staticArgGen(nm) :: { (nm,StaticArg) }+ : 'type' nm type { ($2, TypeArg $3) }+ | 'const' nm expression { ($2, ExprArg $3) }+ | nodeType nm effNode { ($2, NodeArg (thing $1) $3) }+ | nm 'not' { ($1, op1Arg $2 Not) }+ | nm 'fby' { ($1, op2Arg $2 Fby) }+ | nm 'pre' { ($1, op1Arg $2 Pre) }+ | nm 'current' { ($1, op1Arg $2 Current) }+ | nm '->' { ($1, op2Arg $2 FbyArr) }+ | nm 'and' { ($1, op2Arg $2 And) }+ | nm 'or' { ($1, op2Arg $2 Or) }+ | nm 'xor' { ($1, op2Arg $2 Xor) }+ | nm '=>' { ($1, op2Arg $2 Implies) }+ | nm '=' { ($1, op2Arg $2 Eq) }+ | nm '<>' { ($1, op2Arg $2 Neq) }+ | nm '<' { ($1, op2Arg $2 Lt) }+ | nm '<=' { ($1, op2Arg $2 Leq) }+ | nm '>' { ($1, op2Arg $2 Gt) }+ | nm '>=' { ($1, op2Arg $2 Geq) }+ | nm 'div' { ($1, op2Arg $2 Div) }+ | nm 'mod' { ($1, op2Arg $2 Mod) }+ | nm '-' { ($1, op2Arg $2 Sub) }+ | nm '+' { ($1, op2Arg $2 Add) }+ | nm '/' { ($1, op2Arg $2 Div) }+ | nm '*' { ($1, op2Arg $2 Mul) }+ | nm 'if' { ($1, opIf $2) }+ | nm name '<<' SepBy1(staticArgSep,staticArg) '>>'+ { ($1, NodeArg Node (toNodeInst $2 $4) )}+ | nm simpleType { ($1, TypeArg $2) }+ | nm simpExpr { ($1, ExprArg $2) }+++-- Names and Identifiers -------------------------------------------------------++name :: { Name }+ : ident { Unqual $1 }+ | QIDENT { toQIdent $1 }+++label :: { Label }+ : IDENT { toLabel $1 }+ | 'mode' { Label "mode" $1 }++ident :: { Ident }+ : label { toIdent $1 }+++-- Combinators -----------------------------------------------------------------+++Perhaps(x) :: { Maybe SourceRange }+ : {- nothing -} { Nothing }+ | x { Just (range $1) }++Opt(x) :: { Maybe x }+ : {- nothing -} { Nothing }+ | x { Just $1 }++ListOf(thing) :: { [thing] }+ : { [] }+ | ListOf1(thing) { $1 }++ListOf1(thing) :: { [thing] }+ : ListOf1_rev(thing) { reverse $1 }++ListOf1_rev(thing) :: { [thing] }+ : thing { [$1] }+ | ListOf1_rev(thing) thing { $2 : $1 }++SepBy1(sep,thing) :: { [thing] }+ : SepBy1_rev(sep,thing) { reverse $1 }++SepBy1_rev(sep,thing) :: { [thing] }+ : thing { [$1] }+ | SepBy1_rev(sep,thing) sep thing { $3 : $1 }+++EndBy1(sep,thing) :: { [thing] }+ : EndBy1_rev(sep,thing) { reverse $1 }++EndBy1_rev(sep,thing) :: { [thing] }+ : thing sep { [$1] }+ | EndBy1_rev(sep,thing) thing sep { $2 : $1 }+++SepEndBy1(sep,thing) :: { [thing] }+ : thing { [$1] }+ | thing sep { [$1] }+ | thing sep SepEndBy1(sep,thing) { $1 : $3 }+++++{++class At t where+ at :: (HasRange a, HasRange b) => a -> b -> t -> t++instance At Expression where+ at x y = ERange (x <-> y)++instance At Type where+ at x y = TypeRange (x <-> y)++instance At StaticArg where+ at x y = ArgRange (x <-> y)++data Located a = Located { loc :: SourceRange, thing :: a }++instance HasRange (Located a) where+ range = loc++optR :: (HasRange a, HasRange b) => Maybe a -> b -> SourceRange+optR x y = case x of+ Nothing -> range y+ Just a -> range a++lat :: HasRange a => a -> b -> Located b+lat x y = Located { loc = range x, thing = y }++mkNodeProfile ::+ Located [InputBinder] -> Located [Binder] -> Located NodeProfile+mkNodeProfile xs ys =+ Located { loc = loc xs <-> loc ys+ , thing = NodeProfile { nodeInputs = thing xs+ , nodeOutputs = thing ys }+ }+++--------------------------------------------------------------------------------++toE1 :: Op1 -> SourceRange -> Expression -> Expression+toE1 op rng expr = ERange (rng <-> expr) (callPrim rng (Op1 op) [expr])++toE2 :: Expression -> SourceRange -> Op2 -> Expression -> Expression+toE2 e1 rng op e2 = ERange (e1 <-> e2) (callPrim rng (Op2 op) [e1,e2])++toEN :: OpN -> SourceRange -> SourceRange -> [Expression] -> Expression+toEN op r1 r2 es = ERange (r1 <-> r2) (callPrim r1 (OpN op) es)++toITE :: SourceRange -> Expression -> Expression -> Expression -> Expression+toITE r e1 e2 e3 = ERange (r <-> e3) (callPrim r ITE [e1,e2,e3])++--------------------------------------------------------------------------------++toLabel :: Lexeme Token -> Label+toLabel l = Label { labText = lexemeText l+ , labRange = lexemeRange l+ }++toIdent :: Label -> Ident+toIdent l = Ident { identLabel = l+ , identResolved = Nothing+ }++toQIdent :: Lexeme Token -> Name+toQIdent l =+ case lexemeToken l of+ TokQualIdent p n -> Qual (Module p)+ Ident { identLabel = Label { labText = n+ , labRange = lexemeRange l+ }+ , identResolved = Nothing+ }+ _ -> panic "toQIdent" [ "Not a qualified identifier", show l ]+++toLit :: Lexeme Token -> Expression+toLit l =+ ERange (lexemeRange l) $+ Lit $+ case lexemeToken l of+ TokInt n -> Int n+ TokReal n -> Real n+ TokBool n -> Bool n+ _ -> panic "toLit" [ "Unexcpected literal", show l ]++toMerge :: SourceRange -> Ident ->+ [(SourceRange,MergeCase Expression)] -> Expression+toMerge r1 x opts = at r1 (last rs) (Merge x cs)+ where+ (rs,cs) = unzip opts++--------------------------------------------------------------------------------++toTypeDecl :: Ident -> Maybe TypeDef -> TypeDecl+toTypeDecl i d = TypeDecl { typeName = i, typeDef = d }++class ToFieldType t where+ toFieldType :: t -> [FieldType]++instance ToFieldType (Label, Type, Expression) where+ toFieldType (x,t,e) = [ FieldType { fieldName = x, fieldType = t+ , fieldDefault = Just e } ]++instance ToFieldType (Label, Type) where+ toFieldType (x,t) = [ FieldType { fieldName = x, fieldType = t+ , fieldDefault = Nothing } ]++instance ToFieldType (Label, [Label], Type) where+ toFieldType (i,is,t) = [ d | x <- i : is, d <- toFieldType (x,t) ]++--------------------------------------------------------------------------------+++class ToConstDef1 t where+ toConstDef1 :: t -> ConstDef++instance ToConstDef1 (Ident, Type) where+ toConstDef1 (i,t) = ConstDef { constName = i+ , constType = Just t+ , constDef = Nothing+ }++instance ToConstDef1 (Ident,Expression) where+ toConstDef1 (i,e) = ConstDef { constName = i+ , constType = Nothing+ , constDef = Just e+ }++instance ToConstDef1 (Ident,Type,Expression) where+ toConstDef1 (i,t,e) = ConstDef { constName = i+ , constType = Just t+ , constDef = Just e+ }+++class ToConstDef t where+ toConstDef :: t -> [ ConstDef ]++instance ToConstDef (Ident, Type) where+ toConstDef x = [ toConstDef1 x ]++instance ToConstDef (Ident, [Ident], Type) where+ toConstDef (i, is, t) = [ d | x <- i:is, d <- toConstDef (i,t) ]++instance ToConstDef (Ident,Expression) where+ toConstDef x = [ toConstDef1 x ]++instance ToConstDef (Ident,Type,Expression) where+ toConstDef x = [ toConstDef1 x ]++--------------------------------------------------------------------------------++simpBinder :: Ident -> Type -> Binder+simpBinder i t = Binder { binderDefines = i+ , binderType = CType { cType = t, cClock = BaseClock }+ }++toVarDeclBase :: ([Ident], Type) -> [ Binder ]+toVarDeclBase (xs,t) = [ simpBinder x t | x <- xs ]++toVarDecl :: ([Ident], Type) -> ClockExpr -> [ Binder ]+toVarDecl (xs,t) c = [ Binder { binderDefines = x+ , binderType = CType { cType = t+ , cClock = KnownClock c }+ } | x <- xs ]++isUnsafe :: Maybe SourceRange -> Safety+isUnsafe unsafe = case unsafe of+ Just _ -> Unsafe+ Nothing -> Safe++--------------------------------------------------------------------------------++toNodeInst :: Name -> [ StaticArg ] -> NodeInst+toNodeInst nm xs = NodeInst c xs+ where+ c = case nm of+ Unqual i+ -- XXX: Use KW? Or maybe just use names everywhere and+ -- identify built-ins in some name resultion pass...+ | txt == "fill" -> iter IterFill+ | txt == "red" -> iter IterRed+ | txt == "fillred" -> iter IterFillRed+ | txt == "map" -> iter IterMap+ | txt == "boolred" -> iter IterBoolRed+ where+ txt = identText i+ iter x = CallPrim (identRange i) (Iter x)+ _ -> CallUser nm++primArg :: SourceRange -> PrimNode -> StaticArg+primArg r p = NodeArg Function (NodeInst (CallPrim r p) [])++op1Arg :: SourceRange -> Op1 -> StaticArg+op1Arg r p = primArg r (Op1 p)+op2Arg r p = primArg r (Op2 p)+opIf r = primArg r ITE++-- | Call a primitive with no static parameters+callPrim :: SourceRange -> PrimNode -> [Expression] -> Expression+callPrim r p es = Call (NodeInst (CallPrim r p) []) es BaseClock Nothing+++--------------------------------------------------------------------------------++tuple :: [Expression] -> Expression+tuple xs =+ case xs of+ [x] -> x+ _ -> Tuple xs+++mkStruct :: Expression -> SourceRange -> [Field Expression] -> Parser Expression+mkStruct e r2 fs =+ do x <- toName e+ pure $ at e r2 $ Struct x fs+ where+ toName e0 =+ case e0 of+ ERange _ e1 -> toName e1+ Var x -> pure x+ _ -> happyErrorAt (sourceFrom (range e))++mkStructU ::+ Expression -> SourceRange -> Name -> [Field Expression] -> Parser Expression+mkStructU e r2 y fs =+ do x <- toName e+ pure $ at e r2 $ UpdateStruct (Just x) (Var y) fs+ where+ toName e0 =+ case e0 of+ ERange _ e1 -> toName e1+ Var x -> pure x+ _ -> happyErrorAt (sourceFrom (range e))+++++--------------------------------------------------------------------------------++mkContract :: SourceRange -> [ContractItem] -> SourceRange -> Contract+mkContract r1 cs r2 = Contract { contractRange = r1 <-> r2+ , contractItems = cs }+++--------------------------------------------------------------------------------+++mkConstCondact :: Lexeme Token -> Expression -> Expression -> Expression+mkConstCondact l e1 e2 =+ case lexemeToken l of+ TokBool b -> if b then e1 else e2+ _ -> panic "mkConstCondact" [ "Unexcpected literal", show l ]++mkCondact :: SourceRange -> SourceRange ->+ ClockExpr -> Expression -> Maybe Expression -> Parser Expression+mkCondact r1 r2 c e mb =+ do e1 <- checkCall r1 e+ pure $ at r1 r2+ $ case mb of+ Nothing -> eOp1 r1 Current e1 Nothing+ Just d -> eOp2 r1 CurrentWith d e1 Nothing+ where+ checkCall l e =+ case e of+ ERange r e1 -> ERange r <$> checkCall r e1+ Call f es BaseClock mTys ->+ pure (Call f [ e `When` c | e <- es ] (KnownClock c) mTys)+ _ -> happyErrorAt (sourceFrom l)++mkCallWhen ::+ SourceRange -> SourceRange -> ClockExpr -> Expression -> Parser Expression+mkCallWhen r1 r2 c e = at r1 r2 <$> checkCall r1 e+ where+ checkCall l e =+ case e of+ ERange r e1 -> ERange r <$> checkCall r e1+ Call f es BaseClock mTys -> pure (Call f es (KnownClock c) mTys)+ _ -> happyErrorAt (sourceFrom l)+++--------------------------------------------------------------------------------++propName :: SourceRange -> Expression -> Label+propName rng e = case e of+ ERange _ e1 -> propName rng e1+ Var x -> Label+ { labText = Text.pack (showPP x)+ , labRange = rng+ }+ _ -> Label+ { labText = synthName+ , labRange = rng+ }+ where+ synthName = "Prop on line " <> Text.pack (show (sourceLine (sourceFrom rng)))++++addContractItemBody :: NodeBody -> ContractItem -> Parser NodeBody+addContractItemBody bod ci =+ case ci of+ Assume l e -> pure bod { nodeEqns = Assert l AssertPre e : nodeEqns bod }+ Guarantee l e -> pure bod { nodeEqns = Property l e : nodeEqns bod }+ GhostConst d -> pure bod { nodeLocals = LocalConst d : nodeLocals bod }+ GhostVar b e -> pure bod { nodeLocals = LocalVar b : nodeLocals bod+ , nodeEqns = Define [ LVar (binderDefines b) ] e+ : nodeEqns bod+ }+ Mode i _ _ -> happyErrorAt (sourceFrom (range i))+ Import i _ _ -> happyErrorAt (sourceFrom (range i))++desugarContract :: NodeDecl -> Parser NodeDecl+desugarContract d =+ case nodeContract d of+ Nothing -> pure d+ Just c ->+ do b <- foldM addContractItemBody bod0 (contractItems c)+ pure d { nodeDef = Just b, nodeContract = Nothing }+ where+ bod0 = case nodeDef d of+ Nothing -> NodeBody { nodeLocals = [], nodeEqns = [] }+ Just b -> b+++++--------------------------------------------------------------------------------++++--------------------------------------------------------------------------------++-- | Parse a program from the given source.+-- We throw a 'ParseError' exception if we fail to parse a program.+parseProgramFrom :: Text {- ^ Label for parse errors -} ->+ IO Text {- ^ The text to parse -} ->+ IO Program {- ^ The parsed program, or exception -}+parseProgramFrom lab io =+ do txt <- io+ case parse program lab txt of+ Left err -> throwIO err+ Right a -> pure a++-- | Parse a program from a UTF-8 encoded file.+-- May throw 'ParseEror' or exceptions related to reading and decoding the file.+parseProgramFromFileUTF8 :: FilePath -> IO Program+parseProgramFromFileUTF8 file =+ parseProgramFrom (Text.pack file) (Text.readFile file)++-- | Parse a program from a Latin-1 encoded file.+-- May throw 'ParseEror' or exceptions related to reading and decoding the file.+parseProgramFromFileLatin1 :: FilePath -> IO Program+parseProgramFromFileLatin1 file =+ parseProgramFrom (Text.pack file) (Text.decodeLatin1 <$> BS.readFile file)++}
+ Language/Lustre/Parser/Lexer.x view
@@ -0,0 +1,427 @@+{+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Language.Lustre.Parser.Lexer+ ( lexer+ , testLexer+ , Lexeme(..)+ , Token(..)+ , Input(..), initialInput+ , SourceRange(..)+ , SourcePos(..)+ , prettySourceRange+ ) where+import Data.Text(Text)+import qualified Data.Text as Text+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Char(isAscii,toLower)+import Data.Ratio((%))++import AlexTools+}+++$letter = [a-zA-Z_]+$octdigit = 0-7+$digit = 0-9+$hexdigit = [0-9a-fA-F]++@ident = $letter ($letter | $digit)*+@qident = @ident "::" @ident++@digs8 = [0-7]++@digs16 = [0-9A-Fa-f]+++@sign = [\+\-]+@num8 = "0o" @digs8+@num10 = [0-9]++@num16 = "0x" @digs16+++@exp10 = [Ee] @sign? @num10+@exp16 = [Pp] @sign? @num10+@float10 = @num10 @exp10+ | (@num10 "." @num10?) @exp10?+ | (@num10? "." @num10) @exp10?+@float16 = @num16 @exp16+ | (@num16 "." @digs16?) @exp16?+ | ("0x" @digs16? "." @digs16) @exp16?++@line_comment = "--"[^\%].* | "--"+@special_comment = "--%"($letter|$digit)*+@special_block = ("(*@" | "/*@")($letter|$digit)*++:-++<parenBlockComment> {+"*)" { setLexerState 0 >> pure [] }+. ;+\n ;+}++<slashBlockComment> {+"*/" { setLexerState 0 >> pure [] }+. ;+\n ;+}+++<0> {+$white+ ;+@line_comment ;+@special_comment { specialComment specialLine }++"(*" { setLexerState parenBlockComment >> pure [] }+"/*" { setLexerState slashBlockComment >> pure [] }+@special_block { specialComment specialBlock }+"*/" { lexeme TokEndSlashComment }+"*)" { lexeme TokEndParenComment }++"package" { lexeme TokKwPackage }+"model" { lexeme TokKwModel }+"uses" { lexeme TokKwUses }+"needs" { lexeme TokKwNeeds }+"provides" { lexeme TokKwProvides }+"is" { lexeme TokKwIs }+"body" { lexeme TokKwBody }+"end" { lexeme TokKwEnd }++"when" { lexeme TokKwWhen }+"current" { lexeme TokKwCurrent }+"currentWith" { lexeme TokKwCurrentWith }+"condact" { lexeme TokKwCondact }+"callWhen" { lexeme TokKwCallWhen }+"pre" { lexeme TokKwPre }+"fby" { lexeme TokKwFby }+"->" { lexeme TokRightArrow }++"div" { lexeme TokKwDiv }+"mod" { lexeme TokKwMod }+"+" { lexeme TokPlus }+"-" { lexeme TokMinus }+"*" { lexeme TokStar }+"**" { lexeme TokStarStar }+"/" { lexeme TokDiv }+++"with" { lexeme TokKwWith }+"if" { lexeme TokKwIf }+"else" { lexeme TokKwElse }+"then" { lexeme TokKwThen }+"merge" { lexeme TokKwMerge }++"step" { lexeme TokKwStep }+".." { lexeme TokDotDot }+"|" { lexeme TokBar }+"^" { lexeme TokHat }++"#" { lexeme TokHash }+"not" { lexeme TokKwNot }+"xor" { lexeme TokKwXor }+"or" { lexeme TokKwOr }+"and" { lexeme TokKwAnd }+"nor" { lexeme TokKwNor }+"true" { lexeme (TokBool True) }+"false" { lexeme (TokBool False) }++"=>" { lexeme TokImplies }+"<" { lexeme TokLt }+"<=" { lexeme TokLeq }+"=" { lexeme TokEq }+">=" { lexeme TokGeq }+">" { lexeme TokGt }+"<>" { lexeme TokNotEq }+":=" { lexeme TokColonEq }+++"int" { lexeme TokKwInt }+"real" { lexeme TokKwReal }+"bool" { lexeme TokKwBool }+"floor" { lexeme TokKwFloor } -- jkind+"subrange" { lexeme TokKwSubrange } -- jkind+"of" { lexeme TokKwOf } -- jkind++"unsafe" { lexeme TokKwUnsafe }+"extern" { lexeme TokKwExtern }+"imported" { lexeme TokKwImported }+"node" { lexeme TokKwNode }+"function" { lexeme TokKwFunction }+"returns" { lexeme TokKwReturns }++"type" { lexeme TokKwType }+"const" { lexeme TokKwConst }+"var" { lexeme TokKwVar }+"struct" { lexeme TokKwStruct }+"enum" { lexeme TokKwEnum }+"contract" { lexeme TokKwContract }+"import" { lexeme TokKwImport }+"assert" { lexeme TokKwAssert }+"assume" { lexeme TokKwAssume }+"guarantee" { lexeme TokKwGuarantee }+"mode" { lexeme TokKwEnsure }+"require" { lexeme TokKwRequire }+"ensure" { lexeme TokKwEnsure }++"%" { lexeme TokMod }+":" { lexeme TokColon }+"," { lexeme TokComma }+";" { lexeme TokSemi }+"." { lexeme TokDot }+"(" { lexeme TokOpenParen }+")" { lexeme TokCloseParen }+"<<" { lexeme TokOpenTT }+">>" { lexeme TokCloseTT }+"[" { lexeme TokOpenBracket }+"]" { lexeme TokCloseBracket }+"{" { lexeme TokOpenBrace }+"}" { lexeme TokCloseBrace }+"let" { lexeme TokKwLet }+"tel" { lexeme TokKwTel }++@ident { lexeme TokIdent }+@ident "::" @ident { qualIdent }+@num8 { lexeme' . TokInt . integerAtBase 8 =<< matchText }+@num10 { lexeme' . TokInt . integerAtBase 10 =<< matchText }+@num10 ".." { numDotDot } -- to avoid conflict with slices+@num16 { lexeme' . TokInt . integerAtBase 16 =<< matchText }+@float10 { lexeme' . TokReal . floating 10 =<< matchText }+@float16 { lexeme' . TokReal . floating 16 =<< matchText }++. { lexeme TokError }+}++{++data Token =+ TokIdent+ | TokQualIdent Text Text+ | TokInt !Integer+ | TokReal !Rational++ | TokKwPackage | TokKwModel+ | TokKwIs+ | TokKwUses | TokKwNeeds | TokKwProvides+ | TokKwBody | TokKwEnd++ | TokKwIf | TokKwThen | TokKwElse+ | TokKwWith | TokKwMerge+++ | TokKwExtern+ | TokKwUnsafe+ | TokKwImported+ | TokKwNode+ | TokKwFunction+ | TokKwReturns++ | TokKwType+ | TokKwConst+ | TokKwVar+ | TokKwLet+ | TokKwTel+ | TokKwStruct+ | TokKwEnum++ | TokKwContract+ | TokKwAssert+ | TokKwAssume+ | TokKwGuarantee+ | TokKwMode+ | TokKwRequire+ | TokKwEnsure+ | TokKwImport+ | TokStartSlashCommentContract+ | TokEndSlashComment+ | TokStartParenCommentContract+ | TokEndParenComment++++ | TokKwCurrent+ | TokKwCurrentWith+ | TokKwCondact+ | TokKwCallWhen+ | TokKwPre+ | TokKwWhen++ | TokKwAnd+ | TokKwNot+ | TokKwOr+ | TokKwXor+ | TokKwNor+ | TokBool Bool++ | TokKwDiv+ | TokKwMod++ | TokKwInt+ | TokKwReal+ | TokKwBool+ | TokKwFloor++ | TokKwStep+ | TokKwFby++ | TokPragmaProperty+ | TokPragmaMain+ | TokPragmaIVC+ | TokPragmaRealizable++ | TokColon+ | TokComma+ | TokSemi+ | TokDot+ | TokDotDot+ | TokColonEq++ | TokOpenParen+ | TokCloseParen+ | TokOpenTT+ | TokCloseTT+ | TokOpenBracket+ | TokCloseBracket+ | TokOpenBrace+ | TokCloseBrace++ | TokRightArrow+ | TokImplies+ | TokLt | TokLeq | TokEq | TokGeq | TokGt | TokNotEq+ | TokPlus | TokMinus | TokStar | TokStarStar | TokDiv | TokMod+ | TokHash+ | TokHat+ | TokBar++ | TokKwSubrange+ | TokKwOf++ | TokEOF+ | TokError+ deriving (Eq,Show)+++lexeme' :: Token -> Action s [Lexeme Token]+lexeme' t = lexeme $! t++numDotDot :: Action s [ Lexeme Token ]+numDotDot =+ do (num,dots) <- Text.break (== '.') <$> matchText+ SourceRange { sourceFrom = from, sourceTo = to } <- matchRange+ let mid = prevPos to+ return [ Lexeme { lexemeText = num+ , lexemeToken = TokInt (integerAtBase 10 num)+ , lexemeRange = SourceRange { sourceFrom = from+ , sourceTo = prevPos mid } }+ , Lexeme { lexemeText = dots+ , lexemeToken = TokDotDot+ , lexemeRange = SourceRange { sourceFrom = mid+ , sourceTo = to } }+ ]+++specialComment :: Map Text Token -> Action s [ Lexeme Token ]+specialComment known =+ do txt <- matchText+ rng <- matchRange+ pure [ Lexeme { lexemeText = txt+ , lexemeToken = Map.findWithDefault TokError txt known+ , lexemeRange = rng } ]++specialBlock :: Map Text Token+specialBlock = Map.fromList+ [ ("(*@contract", TokStartParenCommentContract)+ , ("/*@contract", TokStartSlashCommentContract)+ ]++specialLine :: Map Text Token+specialLine = Map.fromList+ [ ("--%PROPERTY", TokPragmaProperty)+ , ("--%MAIN", TokPragmaMain)+ , ("--%IVC", TokPragmaIVC)+ , ("--%REALIZABLE", TokPragmaRealizable)+ ]++++qualIdent :: Action s [ Lexeme Token ]+qualIdent =+ do ~[a,b] <- Text.splitOn "::" <$> matchText+ lexeme (TokQualIdent a b)++integerAtBase :: Integer -> Text -> Integer+integerAtBase base txt = if sgn == "-" then negate aval else aval+ where+ aval = Text.foldl' addDig 0 digs+ (sgn,txt0) = splitSign (Text.map toLower txt)+ digs = Text.dropWhile (\x -> x == '0' || x == 'x' || x == 'o') txt0++ addDig s x = s * base + (if y < a then y - z else 10 + (y - a))+ where+ y = val x+ a = val 'a'+ z = val '0'+ val = fromIntegral . fromEnum++splitSign :: Text -> (Text,Text)+splitSign = Text.span (\x -> x == '+' || x == '-')++floating :: Integer -> Text -> Rational+floating fb txt =+ case Text.splitOn exSym (Text.map toLower txt) of+ [base] -> parseBase base+ [base,ex]+ | e >= 0 -> b * fromInteger exVal ^ e+ | otherwise -> b / fromInteger exVal ^ abs e+ where+ e = integerAtBase 10 ex+ b = parseBase base++ _ -> error "[bug] unexpected floating number"+ where+ (exSym,exVal,dbase) = if fb == 10 then ("e",10,10) else ("p",2,16)++ parseBase base =+ let (sign,rest) = splitSign base+ addSign = if sign == "-" then negate else id+ in addSign+ $ case Text.splitOn "." rest of+ [x] -> fromInteger (integerAtBase dbase x)+ [x,y] -> fromInteger (integerAtBase dbase x) + + integerAtBase dbase y % dbase ^ Text.length y+ _ -> error "[bug] unexpected floating number base"+++alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)+alexGetByte = makeAlexGetByte toByte+ where+ toByte ch | isAscii ch = fromIntegral (fromEnum ch)+ | otherwise = 0 -- Should cause an error token to be emitted++lexer :: Input -> [Lexeme Token]+lexer = $makeLexer cfg { lexerEOF = \_ p -> [eof p] }+ where eof p = Lexeme { lexemeToken = TokEOF+ , lexemeText = ""+ , lexemeRange = AlexTools.range p+ }+ err p = Lexeme { lexemeToken = TokError+ , lexemeText = "Unterminated comment."+ , lexemeRange = AlexTools.range p+ }+ cfg = LexerConfig { lexerInitialState = 0+ , lexerStateMode = id+ , lexerEOF = \s p ->+ [ if s == 0 then eof p else err p ]+ }++testLexer :: String -> [Lexeme Token]+testLexer txt = lexer+ Input { inputPos = p0+ , inputText = Text.pack txt+ , inputPrev = prevPos p0+ , inputPrevChar = '\n'+ }+ where p0 = startPos "(test)"+}++
+ Language/Lustre/Parser/Monad.hs view
@@ -0,0 +1,109 @@+{-# Language OverloadedStrings #-}+module Language.Lustre.Parser.Monad+ ( Parser+ , parseStartingAt+ , parse+ , happyGetToken+ , happyError+ , happyErrorAt+ , ParseError(..)+ ) where++import Control.Monad(liftM,ap)+import Control.Exception (Exception)+import Data.Text(Text)+import AlexTools(prevPos, startPos, range)+import Text.PrettyPrint++import Language.Lustre.Parser.Lexer+import Language.Lustre.Pretty+import Language.Lustre.Panic++newtype Parser a = Parser (PState -> Either ParseError (a, PState))++data PState = PState+ { curToken :: Maybe (Lexeme Token)+ , nextToknes :: [Lexeme Token]+ }++{-| Run the given parser on the input text. We always try to parse the+whole text, starting at the input, and report an error if there was+left-overs at the end.++The given source position should correspond to the first character in+the text. -}+parseStartingAt ::+ Parser a {- ^ Describes how to parse the input -} ->+ SourcePos {- ^ Location for the first character in the text -} ->+ Text {- ^ Parse this text -} ->+ Either ParseError a+parseStartingAt (Parser m) p txt =+ case m s0 of+ Left err -> Left err+ Right (a,sFin) ->+ case nextToknes sFin of+ [] -> Right a+ l : _ -> Left $ ParseError $ lexemeRange l+ where+ s0 = PState { curToken = Nothing, nextToknes = lexer input }++ input = Input { inputPos = p+ , inputText = txt+ , inputPrev = pPos+ , inputPrevChar =+ if sourceLine pPos == sourceLine p then ' ' else '\n'+ }+ pPos = prevPos p++parse :: Parser a {- ^ Describes how to parse -} ->+ Text {- ^ Name for the input text (e.g., file name) -} ->+ Text {- ^ The text to parse -} ->+ Either ParseError a+parse p inp = p `parseStartingAt` startPos inp+++++instance Functor Parser where+ fmap = liftM++instance Applicative Parser where+ pure a = Parser (\ls -> Right (a,ls))+ (<*>) = ap++instance Monad Parser where+ Parser m >>= k = Parser (\ls -> case m ls of+ Left err -> Left err+ Right (a,ls1) ->+ let Parser m1 = k a+ in m1 ls1)++happyGetToken :: (Lexeme Token -> Parser a) -> Parser a+happyGetToken k = Parser $ \s ->+ case nextToknes s of+ [] -> panic "happyGetToken" ["We run out of tokens.", "Missing TokEOF?"]+ t : ts -> let Parser m = k t+ in m PState { curToken = Just t, nextToknes = ts }++newtype ParseError = ParseError SourceRange+ deriving Show++instance Exception ParseError++happyErrorAt :: SourcePos -> Parser a+happyErrorAt p = Parser (\_ -> Left (ParseError (range p)))++happyError :: Parser a+happyError = Parser $ \s ->+ Left $ ParseError+ $ case curToken s of+ Nothing ->+ case nextToknes s of+ [] -> panic "happyGetToken" ["We run out of tokens.", "Missing TokEOF?"]+ t : _ -> lexemeRange t+ Just t -> lexemeRange t++instance Pretty ParseError where+ ppPrec _ (ParseError x) =+ text (prettySourceRange x ++ ": Parse error.")+
+ Language/Lustre/Phase.hs view
@@ -0,0 +1,22 @@+module Language.Lustre.Phase where++import Data.Set(Set)+import qualified Data.Set as Set++data LustrePhase = PhaseRename+ | PhaseTypecheck+ | PhaseNoStatic+ | PhaseNoStruct+ | PhaseInline+ | PhaseToCore+ deriving (Show,Eq,Ord,Enum,Bounded)++noPhases :: Set LustrePhase+noPhases = Set.empty++allPhases :: Set LustrePhase+allPhases = Set.fromList [ minBound .. maxBound ]++phases :: [LustrePhase] -> Set LustrePhase+phases = Set.fromList+
+ Language/Lustre/Pretty.hs view
@@ -0,0 +1,539 @@+{-# Language OverloadedStrings #-}+module Language.Lustre.Pretty where++import Data.Semigroup ( (<>) )+import Data.Text (Text)+import Data.List(intersperse)+import qualified Data.Text as Text+import Text.PrettyPrint hiding ( (<>) )+import qualified Text.PrettyPrint as PP+import Numeric(showGFloat)+import Data.Ratio(numerator,denominator)++import Language.Lustre.AST+import Language.Lustre.Name+import Language.Lustre.Panic(panic)+import AlexTools(prettySourceRange)++class Pretty t where+ ppPrec :: Int -> t -> Doc++-- | Pretty print with precedence 0.+pp :: Pretty t => t -> Doc+pp = ppPrec 0++-- | Pretty print with precedence 0, then convert to a 'String'.+showPP :: Pretty t => t -> String+showPP = show . pp++-- | Join vertically, with a space between each element.+vcatSep :: [Doc] -> Doc+vcatSep = vcat . intersperse " "++commaSep :: [Doc] -> Doc+commaSep = hsep . punctuate comma++bullet :: Doc+bullet = "•"++bullets :: [Doc] -> Doc+bullets xs = vcat [ bullet <+> x | x <- xs ]++backticks :: Doc -> Doc+backticks x = "`" PP.<> x PP.<> "`"++nested :: Doc -> Doc -> Doc+nested x y = x $$ nest 2 y++instance Pretty Text where+ ppPrec _ = text . Text.unpack++instance Pretty SourceRange where+ ppPrec _ = text . prettySourceRange++instance Pretty Ident where+ ppPrec n i = ppPrec n (identText i) {- <> _mbId -}+ where _mbId = case identResolved i of+ Nothing -> "?"+ Just on -> int (rnUID on)++instance Pretty Name where+ ppPrec n nam =+ case nam of+ Unqual i -> ppPrec n i+ Qual x y -> ppPrec n x PP.<> "::" PP.<> ppPrec n y++--------------------------------------------------------------------------------++instance Pretty Integer where+ ppPrec _ = integer++instance Pretty Int where+ ppPrec _ x = text (show x)++instance Pretty TopDecl where+ ppPrec n td =+ case td of+ DeclareType dt -> ppPrec n dt+ DeclareConst cd -> ppPrec n cd <> semi+ DeclareNode nd -> ppPrec n nd+ DeclareNodeInst nid -> ppPrec n nid+ DeclareContract cd -> ppPrec n cd++instance Pretty ConstDef where+ ppPrec _ def = "const" <+> pp (constName def) <+>+ opt ":" (constType def) <+>+ opt "=" (constDef def)+ where+ opt x y = case y of+ Nothing -> empty+ Just a -> x <+> pp a++instance Pretty TypeDecl where+ ppPrec _ t = "type" <+> pp (typeName t) <+> mbDef+ where mbDef = case typeDef t of+ Nothing -> semi+ Just d -> "=" <+> pp d PP.<> semi++instance Pretty TypeDef where+ ppPrec _ td =+ case td of+ IsType t -> pp t+ IsEnum is -> "enum" <+> braces (hsep (punctuate comma (map pp is)))+ IsStruct fs -> braces (vcat (punctuate semi (map pp fs)))++instance Pretty NodeInstDecl where+ ppPrec _ nid =+ ppSafetyOpt (nodeInstSafety nid) <+>+ pp (nodeInstType nid) <+>+ pp (nodeInstName nid) <+>+ ppSaticParams (nodeInstStaticInputs nid) <+>+ profDoc <+>+ "=" <+> pp (nodeInstDef nid) PP.<> semi+ where+ profDoc =+ case nodeInstProfile nid of+ Nothing -> empty+ Just p -> pp p++ppSaticParams :: [StaticParam] -> Doc+ppSaticParams xs =+ case xs of+ [] -> empty+ _ -> "<<" PP.<> hsep (punctuate semi (map pp xs)) PP.<> ">>"++instance Pretty NodeProfile where+ ppPrec _ np =+ parens (hsep (punctuate semi (map pp (nodeInputs np)))) <+>+ "returns" <+> parens (hsep (punctuate semi (map pp (nodeOutputs np))))++instance Pretty InputBinder where+ ppPrec n ib =+ case ib of+ InputBinder b -> ppPrec n b+ InputConst i t -> "const" <+> pp i <+> ":" <+> pp t++instance Pretty Binder where+ ppPrec _ b = pp (binderDefines b) <+> ":" <+> pp (cType ty) <+> clockDoc+ where+ ty = binderType b+ clockDoc = case cClock ty of+ BaseClock -> empty+ KnownClock c -> "when" <+> pp c+ ClockVar i -> "when" <+> pp i++instance Pretty StaticParam where+ ppPrec _ sp =+ case sp of+ TypeParam i -> "type" <+> pp i+ ConstParam i t -> "const" <+> pp i <+> ":" <+> pp t+ NodeParam s nt f p -> ppSafetyOpt s <+> pp nt <+> pp f <+> pp p+++instance Pretty NodeDecl where+ ppPrec _ nd =+ ppSafetyOpt (nodeSafety nd) <+>+ (if nodeExtern nd then "extern" else empty) <+>+ pp (nodeType nd) <+>+ pp (nodeName nd) <+>+ ppSaticParams (nodeStaticInputs nd) <+>+ pp (nodeProfile nd) $$+ maybe empty pp (nodeContract nd) $$+ bodyDoc+ where bodyDoc = case nodeDef nd of+ Nothing -> semi+ Just x -> pp x++instance Pretty NodeBody where+ ppPrec _ nb =+ nest 2 (vcat [ pp d <> semi | d <- nodeLocals nb ]) $$+ "let" $$+ nest 2 (vcat [ pp d <> semi | d <- nodeEqns nb ]) $$+ "tel"++instance Pretty LocalDecl where+ ppPrec _ ld =+ case ld of+ LocalVar b -> "var" <+> pp b+ LocalConst c -> "const" <+> pp c++instance Pretty Equation where+ ppPrec _ eqn =+ case eqn of+ Assert _ ty e -> "assert" <+> tyd <+> pp e+ where tyd = case ty of+ AssertPre -> empty+ AssertEnv -> "/*env*/"+ Define ls e -> lhs <+> "=" <+> pp e+ where lhs = case ls of+ [] -> "()"+ _ -> hsep (map pp ls)+ IsMain _ -> "--%MAIN"+ IVC is -> "--%IVC" <+> commaSep (map pp is)+ Realizable is -> "--%REALIZABLE" <+> commaSep (map pp is)+ Property _ e -> "--%PROPERTY" <+> pp e++instance Pretty e => Pretty (LHS e) where+ ppPrec _ lhs =+ case lhs of+ LVar x -> pp x+ LSelect l s -> pp l <> pp s++--------------------------------------------------------------------------------+++instance Pretty FieldType where+ ppPrec _ ft = pp (fieldName ft) <+> pp (fieldType ft) <+> optVal+ where optVal = case fieldDefault ft of+ Nothing -> empty+ Just e -> "=" <+> pp e++instance Pretty Type where+ ppPrec n ty =+ case ty of+ NamedType x -> pp x+ ArrayType t e -> pp t <+> "^" <+> pp e -- precedence?+ IntType -> "int"+ RealType -> "real"+ BoolType -> "bool"+ IntSubrange e1 e2 ->+ "subrange" <+> brackets (hsep (punctuate comma (map pp [e1,e2])))+ <+> "of" <+> "int"+ TypeRange _ t -> ppPrec n t+++instance Pretty Literal where+ ppPrec _ lit =+ case lit of+ Int n -> integer n+ Bool b -> if b then "true" else "false"+ Real r | toRational t == r -> text (showGFloat Nothing t "")+ | otherwise -> parens (sh (numerator r) <+> "/" <+>+ sh (denominator r))+ where+ t = fromRational r :: Double+ sh x = integer x <> ".0"++{-+Precedences:+1 %left '|'+2 %nonassoc '->'+3 %right '=>'+4 %left 'or' 'xor'+5 %left 'and'+6 %nonassoc '<' '<=' '=' '>=' '>' '<>'+7 %nonassoc 'not' PREF+8 %left '+' '-'+9 %left '*' '/' '%' 'mod' 'div'+10 %left '**'+11 %nonassoc 'when'+12 %nonassoc 'int' 'real' PREF+13 %nonassoc UMINUS 'pre' 'current' PREF+14 %left '^' '.'+15 %right 'fby'+16 %right '[' '{'+-}+instance Pretty Expression where+ ppPrec n expr =+ case expr of+ ERange _ e -> ppPrec n e+ Var x -> pp x+ Const e t -> pp e <+> mbClock+ where mbClock = case cClock t of+ BaseClock -> empty+ _ -> "/*" <+> pp (cClock t) <+> "*/"+ Lit l -> pp l+ e `When` ce -> parenIf (n > 10) doc+ where doc = ppPrec 11 e <+> "when" <+> ppPrec 11 ce++ Tuple es -> parens (commaSep (map pp es))+ Array es -> brackets (commaSep (map pp es))+ Select e s -> ppPrec 13 e <> pp s+ Struct s fs -> pp s <+> braces (vcat (punctuate semi (map pp fs)))+ UpdateStruct mb x fs ->+ case mb of+ Just s -> pp s <+> braces (pp x <+> "with" <+>+ vcat (punctuate semi (map pp fs)))+ Nothing -> ppPrec 16 x <+> hsep (map ppF fs)+ where ppF f = braces (pp (fName f) <+> ":=" <+> pp (fValue f))++ WithThenElse e1 e2 e3 -> parenIf (n > 0) doc+ where doc = "with" <+> pp e1 $$ nest 2 ("then" <+> ppPrec 0 e2)+ $$ nest 2 ("else" <+> ppPrec 0 e3)++ Merge i as -> parenIf (n > 1) doc+ where doc = "merge" <+> pp i $$ nest 2 (vcat (map pp as))++ Call f es cl _ ->+ case (f,cl) of+ (NodeInst (CallPrim _ prim) [], BaseClock) ->+ case (prim, es) of++ (Op1 op, [e]) -> parenIf (n >= p) doc+ where doc = pp op <+> ppPrec p e+ p = case op of+ Not -> 7+ IntCast -> 12+ RealCast -> 12+ FloorCast -> 12+ Neg -> 13+ Pre -> 13+ Current -> 13++ (Op2 CurrentWith,_) -> dflt -- not infix++ (Op2 op, [e1,e2]) -> parenIf (n >= p) doc+ where doc = ppPrec lp e1 <+> pp op <+> ppPrec rp e2+ left x = (x-1,x,x)+ right x = (x,x,x-1)+ non x = (x,x,x)++ (lp,p,rp) = case op of+ Concat -> left 1+ FbyArr -> non 2+ Implies -> right 3+ CurrentWith -> panic "pp" ["currentWith?"]+ Or -> left 4+ Xor -> left 4+ And -> left 5+ Lt -> non 6+ Leq -> non 6+ Gt -> non 6+ Geq -> non 6+ Eq -> non 6+ Neq -> non 6+ Add -> left 8+ Sub -> left 8+ Mul -> left 9+ Div -> left 9+ Mod -> left 9+ Power -> left 10+ Replicate -> left 14+ Fby -> right 15++ (ITE,[e1,e2,e3]) -> parenIf (n > 0) doc+ where doc = "if" <+> pp e1 $$ nest 2 ("then" <+> ppPrec 0 e2)+ $$ nest 2 ("else" <+> ppPrec 0 e3)++ _ -> dflt++ _ -> dflt+ where+ argTuple = parens (commaSep (map pp es))+ dflt = case cl of+ BaseClock -> pp f <+> argTuple+ KnownClock c -> "callWhen" <+>+ parens (commaSep [ pp c, pp f <+> argTuple])+ ClockVar c -> "callWhen" <+> pp c++parenIf :: Bool -> Doc -> Doc+parenIf p d = if p then parens d else d+++instance Pretty e => Pretty (MergeCase e) where+ ppPrec _ (MergeCase cv e) = parens (pp cv <+> "->" <+> pp e)++instance Pretty e => Pretty (Field e) where+ ppPrec _ (Field x e) = pp x <+> "=" <+> pp e++instance Pretty e => Pretty (Selector e) where+ ppPrec _ sel =+ case sel of+ SelectField i -> "." <> pp i+ SelectElement e -> brackets (pp e)+ SelectSlice e -> brackets (pp e)++instance Pretty e => Pretty (ArraySlice e) where+ ppPrec _ as = pp (arrayStart as) <+> ".." <+> pp (arrayEnd as) <+> mbStep+ where mbStep = case arrayStep as of+ Nothing -> empty+ Just e -> "step" <+> pp e++instance Pretty ClockExpr where+ ppPrec _ (WhenClock _ cv i) =+ case cv of+ Lit (Bool True) -> pp i+ Lit (Bool False) -> "not" <+> pp i+ _ -> ppPrec 16 cv <> parens (pp i)++instance Pretty NodeInst where+ ppPrec _ (NodeInst x as) =+ case as of+ [] -> pp x+ _ -> pp x <+> "<<" PP.<> hsep (punctuate comma (map pp as)) PP.<> ">>"++instance Pretty Callable where+ ppPrec p c =+ case c of+ CallUser n -> ppPrec p n+ CallPrim _ i -> ppPrec p i++instance Pretty PrimNode where+ ppPrec p x =+ case x of+ Iter i -> ppPrec p i+ Op1 op -> ppPrec p op+ Op2 op -> ppPrec p op+ OpN op -> ppPrec p op+ ITE -> "if"++instance Pretty Iter where+ ppPrec _ i =+ case i of+ IterFill -> "fill"+ IterRed -> "red"+ IterFillRed -> "fillred"+ IterMap -> "map"+ IterBoolRed -> "boolred"++instance Pretty StaticArg where+ ppPrec n arg =+ case arg of+ TypeArg t -> "type" <+> pp t+ ExprArg e -> "const" <+> pp e+ NodeArg nf x -> case x of+ NodeInst (CallUser _) _ -> pp nf <+> pp x+ _ -> pp x+ ArgRange _ a -> ppPrec n a++instance Pretty NodeType where+ ppPrec _ nt =+ case nt of+ Node -> "node"+ Function -> "function"++-- | Pretty print a safety, but don't say anything if safe.+ppSafetyOpt :: Safety -> Doc+ppSafetyOpt saf =+ case saf of+ Safe -> empty+ Unsafe -> "unsafe"++instance Pretty Safety where+ ppPrec _ saf =+ case saf of+ Safe -> "/* safe */" -- so that it makes sense when printed+ -- on its own+ Unsafe -> "unsafe"++instance Pretty Op1 where+ ppPrec _ op =+ case op of+ Not -> "not"+ Neg -> "-"+ Pre -> "pre"+ Current -> "current"+ IntCast -> "int"+ FloorCast -> "floor"+ RealCast -> "real"++instance Pretty Op2 where+ ppPrec _ op =+ case op of+ FbyArr -> "->"+ Fby -> "fby"+ CurrentWith -> "currentWith"+ And -> "and"+ Or -> "or"+ Xor -> "xor"+ Implies -> "=>"+ Eq -> "="+ Neq -> "<>"+ Lt -> "<"+ Leq -> "<="+ Gt -> ">"+ Geq -> ">="+ Mul -> "*"+ Mod -> "mod"+ Div -> "/"+ Add -> "+"+ Sub -> "-"+ Power -> "**"+ Replicate -> "^"+ Concat -> "|"++instance Pretty OpN where+ ppPrec _ op =+ case op of+ AtMostOne -> "#"+ Nor -> "nor"++--------------------------------------------------------------------------------++instance Pretty Contract where+ ppPrec _ c = "/*@contract" $$ nest 2 (vcat (map pp (contractItems c))) $$ "*/"++instance Pretty ContractItem where+ ppPrec _ item =+ case item of+ GhostConst d -> pp d+ GhostVar b e -> "var" <+> pp b <+> "=" <+> pp e PP.<> semi+ Assume _ e -> "assume" <+> pp e PP.<> semi+ Guarantee _ e -> "guarantee" <+> pp e PP.<> semi+ Mode i res ens -> "mode" <+> pp i <+> "("+ $$ nest 2 (vcat (map (ppClause "requre") res))+ $$ nest 2 (vcat (map (ppClause "ensure") ens))+ $$ ")" PP.<> semi+ where ppClause x e = x <+> pp e PP.<> semi+ Import i eis eos ->+ "import" <+> pp i PP.<> parens (commaSep (map pp eis))+ <+> parens (commaSep (map pp eos))++instance Pretty ContractDecl where+ ppPrec _ cd =+ "contract" <+> pp (cdName cd) <+> pp (cdProfile cd) PP.<> semi+ $$ "let" $$ nest 2 (vcat (map pp (cdItems cd))) $$ "tel"++++instance Pretty Thing where+ ppPrec _ th =+ case th of+ AType -> "type"+ ANode -> "node"+ AContract -> "contract"+ AConst -> "constant"+ AVal -> "value"+++instance Pretty ModName where+ ppPrec _ (Module t) = pp t++instance Pretty Label where+ ppPrec _ = pp . labText+++instance Pretty OrigName where+ ppPrec _ x = pp (origNameToIdent x)+++instance Pretty IClock where+ ppPrec n c = case c of+ BaseClock -> "base clock"+ KnownClock k -> ppPrec n k+ ClockVar v -> pp v++instance Pretty CVar where+ ppPrec _ (CVar i) = "cv_" PP.<> pp i++
+ Language/Lustre/Semantics/BuiltIn.hs view
@@ -0,0 +1,250 @@+module Language.Lustre.Semantics.BuiltIn+ ( -- * Constants+ sInt, sReal, sBool++ -- ** Coercions+ , sReal2Int, sInt2Real, sReal2IntFloor++ -- ** Logical operators+ , sNot, sAnd, sOr, sXor, sImplies, sBoolRed++ -- ** Relations and choices+ , sEq, sNeq, sLt, sGt, sLeq, sGeq, sITE++ -- ** Arithmetic+ , sNeg, sAdd, sSub, sMul, sDiv, sMod, sPow, eucledean_div_mod++ -- * Data structures+ , sArray, sReplicate, sConcat, sSelectIndex, sSelectSlice+ , sSelectField++ ) where++import Data.List(genericReplicate,genericDrop,genericIndex,genericLength)++import Language.Lustre.Name+import Language.Lustre.AST+import Language.Lustre.Semantics.Value++++--------------------------------------------------------------------------------+-- Static++sInt :: Integer -> EvalM Value+sInt x = pure (VInt x)++sReal :: Rational -> EvalM Value+sReal x = pure (VReal x)++sBool :: Bool -> EvalM Value+sBool x = pure (VBool x)++sArray :: [Value] -> EvalM Value+sArray x = pure (VArray x)++sNot :: Value -> EvalM Value+sNot v =+ case v of+ VBool x -> sBool (not x)+ _ -> typeError "not" "a `bool`"++sNeg :: Value -> EvalM Value+sNeg v =+ case v of+ VInt x -> sInt (negate x)+ VReal x -> sReal (negate x)+ _ -> typeError "uminus" "a `real` or a `number`"++sReal2Int :: Value -> EvalM Value+sReal2Int v =+ case v of+ VReal x -> sInt (truncate x)+ _ -> typeError "real2int" "a `real`"++sReal2IntFloor :: Value -> EvalM Value+sReal2IntFloor v =+ case v of+ VReal x -> sInt (floor x)+ _ -> typeError "real2intFloor" "a `real`"++++sInt2Real :: Value -> EvalM Value+sInt2Real v =+ case v of+ VInt x -> sReal (fromInteger x)+ _ -> typeError "int2real" "an `int`"+++sOp2 :: (Value -> Value -> EvalM Value) -> Value -> Value -> EvalM Value+sOp2 f u v =+ case (u,v) of+ _ -> f u v++sBoolOp2 :: String -> (Bool -> Bool -> Bool) -> Value -> Value -> EvalM Value+sBoolOp2 name f =+ sOp2 $ \u v ->+ case (u,v) of+ (VBool x, VBool y) -> sBool (f x y)+ _ -> typeError name "`(bool,bool)`"++sAnd, sOr, sXor, sImplies :: Value -> Value -> EvalM Value+sAnd = sBoolOp2 "and" (&&)+sOr = sBoolOp2 "or" (||)+sXor = sBoolOp2 "xor" (/=)+sImplies = sBoolOp2 "implies" (\p q -> not p || q)++sEq :: Value -> Value -> EvalM Value+sEq = sOp2 $ \u v -> sBool (u == v)++sNeq :: Value -> Value -> EvalM Value+sNeq = sOp2 $ \u v -> sBool (u /= v)++sCmpOp :: String -> (Ordering -> Bool) -> Value -> Value -> EvalM Value+sCmpOp name f = sOp2 $ \u v ->+ case (u,v) of+ (VInt x, VInt y) -> sBool (f (compare x y))+ (VReal x, VReal y) -> sBool (f (compare x y))+ _ -> typeError name "`(int,int)` or `(real,real)`"++sLt, sGt, sLeq, sGeq :: Value -> Value -> EvalM Value+sLt = sCmpOp "lt" (== LT)+sGt = sCmpOp "gt" (== GT)+sLeq = sCmpOp "leq" (\x -> x == LT || x == EQ)+sGeq = sCmpOp "geq" (\x -> x == GT || x == EQ)++sMul, sDiv, sMod, sPow, sAdd, sSub :: Value -> Value -> EvalM Value++sMul = sOp2 $ \u v ->+ case (u,v) of+ (VInt x, VInt y) -> sInt (x * y)+ (VReal x, VReal y) -> sReal (x * y)+ _ -> typeError "times" "`(int,int)` or `(real,real)`"++sDiv = sOp2 $ \u v ->+ case (u,v) of+ (VInt x, VInt y) ->+ case eucledean_div_mod x y of+ Just (q,_) -> sInt q+ Nothing -> crash "div" "Division by 0"+ (VReal x, VReal y)+ | y /= 0 -> sReal (x / y)+ | otherwise -> crash "div" "Division by 0"++ _ -> typeError "div" "`(int,int)` or `(real,real)`"++sMod = sOp2 $ \u v ->+ case (u,v) of+ (VInt x, VInt y) ->+ case eucledean_div_mod x y of+ Just (_,r) -> sInt r+ Nothing -> crash "mod" "Division by 0"+ _ -> typeError "mod" "`(int,Int)`"++sAdd = sOp2 $ \u v ->+ case (u,v) of+ (VInt x, VInt y) -> sInt (x + y)+ (VReal x, VReal y) -> sReal (x + y)+ _ -> typeError "add" "`(int,int)` or `(real,real)`"+++sSub = sOp2 $ \u v ->+ case (u,v) of+ (VInt x, VInt y) -> sInt (x - y)+ (VReal x, VReal y) -> sReal (x - y)+ _ -> typeError "sub" "`(int,int)` or `(real,real)`"++sPow = sOp2 $ \u v ->+ case (u,v) of+ (VInt x, VInt y) -> sInt (x ^ y)+ (VReal x, VInt y) -> sReal (x ^ y)+ _ -> typeError "pow" "`(int,int)` or `(real,int)`"+++-- | Convenient operator used by various boolean functions.+-- The integeras ar the minimum and maximum number of true in the list of value.+sBoolRed :: String -> Integer -> Integer -> [Value] -> EvalM Value+sBoolRed name i j = count 0+ where+ count n as = case as of+ [] -> pure (VBool (n >= i))+ VBool b : bs+ | b -> if n == j then pure (VBool False)+ else count (n+1) bs++ _ -> typeError name "a `bool`"++sITE :: Value -> Value -> Value -> EvalM Value+sITE u v w =+ case u of+ VBool b -> pure (if b then v else w)+ _ -> typeError "ite" "a `bool`"+++sReplicate :: Value {-^ Replicate this -} -> Value {-^ Number of times -} ->+ EvalM Value+sReplicate = sOp2 $ \u v ->+ case v of+ VInt x -> sArray (genericReplicate x u)+ _ -> typeError "replicate" "an `int`"++sConcat :: Value -> Value -> EvalM Value+sConcat = sOp2 $ \u v ->+ case (u,v) of+ (VArray xs, VArray ys) -> sArray (xs ++ ys)+ _ -> typeError "concat" "(array,array)"+++sSelectField :: Label -> Value -> EvalM Value+sSelectField f v =+ case v of+ VStruct _ fs ->+ case [ fv | Field f1 fv <- fs, f1 == f ] of+ fv : _ -> pure fv+ [] -> crash "select-field" "Missing struct field"+ _ -> typeError "select-field" "a struct type."++sSelectIndex :: Value {-^ index -} -> Value {- ^ array -} -> EvalM Value+sSelectIndex = sOp2 $ \i v ->+ case (v,i) of+ (VArray vs, VInt iv)+ | iv < 0 -> outOfBounds+ | otherwise -> case genericDrop iv vs of+ [] -> outOfBounds+ x : _ -> pure x+ where outOfBounds = typeError "sSelectIndex" "array index out of bounds"++ _ -> typeError "select-element" "`(array,int)`"++sSelectSlice :: ArraySlice Value -> Value -> EvalM Value+sSelectSlice sl v =+ case (v, start, end, step) of+ (VArray vs, VInt f, VInt t, VInt s)+ | f >= 0 && t >= f && t < genericLength vs && s > 0 ->+ sArray [ genericIndex vs i | i <- [ f, f + s .. t ] ]+ | otherwise -> crash "get-slice" "Bad arguments"++ _ -> typeError "get-slice" "(array,int,int,int)"+ where+ start = arrayStart sl+ end = arrayEnd sl+ step = case arrayStep sl of+ Just s -> s+ Nothing -> VInt 1++++eucledean_div_mod :: Integer -> Integer -> Maybe (Integer,Integer)+eucledean_div_mod x y =+ do q <- doDiv x y+ let r = x - q * y+ pure (q, r)+ where+ doDiv a b = case compare b 0 of+ LT -> Just (negate (doDivPos a (negate b)))+ EQ -> Nothing+ GT -> Just (doDivPos a b)++ doDivPos a b = floor (toRational a / toRational b)+
+ Language/Lustre/Semantics/Const.hs view
@@ -0,0 +1,220 @@+module Language.Lustre.Semantics.Const+ ( evalConst, evalSel, evalSelFun, Env(..), emptyEnv, evalIntConst, valToExpr+ , Value(..)+ )+ where++import Data.Map ( Map )+import qualified Data.Map as Map+import Control.Monad(msum)++import Language.Lustre.Name+import Language.Lustre.AST+import Language.Lustre.Pretty(showPP)+import Language.Lustre.Semantics.Value+import Language.Lustre.Semantics.BuiltIn++data Env = Env+ { envConsts :: Map OrigName Value+ , envStructs :: Map OrigName [ (Label, Maybe Value) ]+ }++emptyEnv :: Env+emptyEnv = Env { envConsts = Map.empty+ , envStructs = Map.empty+ }+++-- | Evaluate a constant expression of type @int@.+evalIntConst :: Env -> Expression -> EvalM Integer+evalIntConst env e =+ do v <- evalConst env e+ case v of+ VInt i -> pure i+ _ -> typeError "evalIntConst" "an `int`"+++-- | Evaluate a constant expression.+-- Note this does not produce 'Nil' values, unless some came in the 'Env'.+evalConst :: Env -> Expression -> EvalM Value+evalConst env expr =+ case expr of++ ERange _ e -> evalConst env e++ Lit l ->+ case l of+ Int n -> sInt n+ Real n -> sReal n+ Bool n -> sBool n++ WithThenElse be t e ->+ do bv <- evalConst env be+ case bv of+ VBool b -> if b then evalConst env t else evalConst env e+ _ -> typeError "with-then-else" "A `bool`"++ Const e _ -> evalConst env e++ When {} -> bad "`when` is not a constant expression."+ Merge {} -> bad "`merge` is not a constant expression."++ Var x ->+ case Map.lookup (nameOrigName x) (envConsts env) of+ Just v -> pure v+ Nothing -> bad ("Undefined variable `" ++ show x ++ "`.")++ Tuple {} -> bad "Unexpected constant tuple."++ Array es -> sArray =<< mapM (evalConst env) es++ Struct s fes ->+ case Map.lookup name (envStructs env) of+ Nothing -> bad ("Undefined struct type `" ++ show s ++ "`.")+ Just structDef ->+ do fs <- Map.fromList <$> mapM (evalField env) fes+ let mkField (f,mb) =+ case msum [ Map.lookup f fs, mb ] of+ Just v -> pure (Field f v)+ Nothing -> bad ("Missing field `" ++ show f ++ "`.")+ fs1 <- mapM mkField structDef+ pure (VStruct name fs1)+ where name = nameOrigName s++ UpdateStruct mbS y fes ->+ do uv <- evalConst env y+ fs <- Map.fromList <$> mapM (evalField env) fes+ case uv of+ VStruct s fs1+ | maybe True ((== s) . nameOrigName) mbS ->+ pure $ VStruct s+ [ Field i v1+ | Field i v <- fs1+ , let v1 = Map.findWithDefault v i fs+ ]+ | otherwise -> typeError "struct update"+ ("a `" ++ showPP s ++ "`")++ _ -> typeError "struct update" "a struct"++ Select e sel ->+ do s <- evalSel env sel+ evalSelFun s =<< evalConst env e++ Call (NodeInst (CallPrim _ p) []) es cl _ ->+ do case cl of+ BaseClock -> pure ()+ _ -> bad "calls with a clock do not make sense for constants"+ vs <- mapM (evalConst env) es+ case (p, vs) of++ (ITE, [b,t,e]) -> sITE b t e++ (Op1 op, [v]) ->+ case op of+ Not -> sNot v+ Neg -> sNeg v+ IntCast -> sReal2Int v+ RealCast -> sInt2Real v+ FloorCast -> sReal2IntFloor v++ Pre -> bad "`pre` is not a constant"+ Current -> bad "`current` is not a constant"++ (Op2 op, [x,y]) ->+ case op of+ Fby -> bad "`fby` is not a constant"+ FbyArr -> bad "`->` is not a constant"+ CurrentWith-> bad "`current` is not a constant"++ And -> sAnd x y+ Or -> sOr x y+ Xor -> sXor x y+ Implies -> sImplies x y++ Eq -> sEq x y+ Neq -> sNeq x y++ Lt -> sLt x y+ Leq -> sLeq x y+ Gt -> sGt x y+ Geq -> sGeq x y++ Mul -> sMul x y+ Mod -> sMod x y+ Div -> sDiv x y+ Add -> sAdd x y+ Sub -> sSub x y+ Power -> sPow x y++ Replicate -> sReplicate x y+ Concat -> sConcat x y++ (OpN op, _) ->+ case op of+ AtMostOne -> sBoolRed "at-most-one" 0 1 vs+ Nor -> sBoolRed "nor" 0 0 vs++ (_, _) -> bad ("Unknown primitive expression: " ++ showPP p)+++ Call {} -> bad "`call` is not a constant expression."++ where+ bad = crash "evalConst"+++evalField :: Env -> Field Expression -> EvalM (Label, Value)+evalField env (Field f v) = do v1 <- evalConst env v+ pure (f,v1)++-- | Evaluate a selector.+evalSel :: Env -> Selector Expression -> EvalM (Selector Value)+evalSel env sel =+ case sel of++ SelectField f ->+ pure (SelectField f)++ SelectElement ei ->+ do i <- evalConst env ei+ pure (SelectElement i)++ SelectSlice s ->+ do start <- evalConst env (arrayStart s)+ end <- evalConst env (arrayEnd s)+ step <- mapM (evalConst env) (arrayStep s)+ pure (SelectSlice ArraySlice { arrayStart = start+ , arrayEnd = end+ , arrayStep = step+ })+++-- | Evaluate a selector to a selecting function.+evalSelFun :: Selector Value -> Value -> EvalM Value+evalSelFun sel v =+ case sel of+ SelectField f -> sSelectField f v+ SelectElement i -> sSelectIndex i v+ SelectSlice s -> sSelectSlice s v+++-- | Convert an evaluated expression back into an ordinary expression.+-- Note that the resulting expression does not have meaninful position+-- information.+valToExpr :: Value -> Expression+valToExpr val =+ case val of+ VInt i -> Lit (Int i)+ VBool b -> Lit (Bool b)+ VReal r -> Lit (Real r)++ -- we keep enums as variables, leaving representation choice for later.+ VEnum _ x -> Var (origNameToName x)+ VStruct s fs -> Struct (origNameToName s) (fmap (fmap valToExpr) fs)++ VArray vs -> Array (map valToExpr vs)++++
+ Language/Lustre/Semantics/Core.hs view
@@ -0,0 +1,392 @@+{-# Language OverloadedStrings #-}+module Language.Lustre.Semantics.Core where++import Data.List(foldl')+import Data.Maybe(fromMaybe)+import Data.Map ( Map )+import qualified Data.Map as Map+import Data.Set ( Set )+import qualified Data.Set as Set+import Text.PrettyPrint++import Language.Lustre.Panic+import Language.Lustre.Pretty+import Language.Lustre.Core+import Language.Lustre.Semantics.BuiltIn(eucledean_div_mod)++data Value = VInt !Integer+ | VBool !Bool+ | VReal !Rational+ | VNil+ deriving Show++isNil :: Value -> Bool+isNil v =+ case v of+ VNil -> True+ _ -> False++isBool :: Value -> Maybe Bool+isBool v =+ case v of+ VBool b -> Just b+ _ -> Nothing++ppValue :: Value -> Doc+ppValue val =+ case val of+ VInt x -> integer x+ VBool x -> text (show x)+ VReal x -> double (fromRational x)+ VNil -> text "nil"++instance Pretty Value where+ ppPrec _ = ppValue+++data State = State+ { sValues :: Map CoreName Value+ -- ^ Values for identifiers.+ -- If a value is missing, then its value is assumed to be 'VNil'.++ , sInitialized :: Set CoreName+ -- ^ Additional state to implement @a -> b@+ -- Contains the identifiers that have transition to the second phase.+ }++ppState :: PPInfo -> State -> Doc+ppState info s =+ vcat [ "values:"+ , nest 2 (vcat (map ppV (Map.toList (sValues s))))+ , "initialized:" <+> commaSep (map ppI (Set.toList (sInitialized s)))+ ]+ where+ ppI = ppIdent info+ ppV (x,y) = ppI x <+> "=" <+> pp y++++instance Pretty State where+ ppPrec _ = ppState noInfo++initNode :: Node ->+ Maybe (Map CoreName Value) {- Optional inital values -} ->+ (State, State -> Map CoreName Value -> State)+initNode node mbStart = (s0, stepNode node env)+ where+ s0 = State { sInitialized = Set.empty+ , sValues = fromMaybe Map.empty mbStart+ }+ env = nodeEnv node+++stepNode :: Node {- ^ Node, with equations properly ordered -} ->+ (Map CoreName CType) {- ^ Types of identifiers -} ->+ State {- ^ Current state -} ->+ Map CoreName Value {- ^ Inputs -} ->+ State {- ^ Next state -}+stepNode node env old ins = foldl' (evalEqnGrp env old) new (nEqns node)+ where+ new = State { sInitialized = sInitialized old+ , sValues = ins+ }+++-- | The meaning of a literal.+evalLit :: Literal -> Value+evalLit lit =+ case lit of+ Int i -> VInt i+ Real r -> VReal r+ Bool b -> VBool b++-- | Lookup the value of a variable.+evalVar :: State -> CoreName -> Value+evalVar s x = Map.findWithDefault VNil x (sValues s)++-- | Interpret an atom in the given state.+evalAtom :: State {-^ Environment to for values of variables -} ->+ Atom {-^ Evaluate this -} ->+ Value {-^ Value of the atom -}+evalAtom s atom =+ case atom of+ Lit l _ -> evalLit l+ Var x -> evalVar s x+ Prim op as _ -> evalPrimOp op (map (evalAtom s) as)+++evalEqnGrp :: Map CoreName CType ->+ State ->+ State ->+ EqnGroup ->+ State+evalEqnGrp env old new grp =+ case grp of+ NonRec eqn -> evalEqn env old new eqn+ Rec es ->+ let evEq = evalEqn env old fin+ sts = map evEq es+ getVal (x ::: _ := _) s = (x,Map.findWithDefault VNil x (sValues s))+ newMap = Map.fromList (zipWith getVal es sts)+ fin = State { sInitialized = Set.unions (map sInitialized sts)+ , sValues = Map.union newMap (sValues new)+ }+ in fin+++++evalEqn :: Map CoreName CType {- ^ Types of identifier -} ->+ State {- ^ Old state -} ->+ State {- ^ New state (partial) -} ->+ Eqn {- ^ Equation to evaluate -} ->+ State {- ^ Updated new state -}++evalEqn env old new (x ::: _ `On` c := expr) =+ case expr of++ Atom a -> guarded $ done $ evalAtom new a+ Current a -> done (evalAtom new a)++ a `When` _ ->+ guarded $ done $+ evalAtom new a++ Pre a ->+ guarded $ done $+ evalAtom old a++ (a, _) :-> b ->+ guarded $+ if x `Set.member` sInitialized old+ then done (evalAtom new b)+ else initialized $ done $ evalAtom new a++ Merge (n, ty) alts ->+ let nameAtom = Var n+ in guarded $ done $+ let go [] = VNil+ go ((lit, e):rest) =+ let cond = Prim Eq [ Lit lit ty, e ] [TBool `On` c]+ in case evalAtom new cond of+ VBool b -> if b+ then evalAtom new e+ else go rest+ VNil -> VNil+ _ -> panic "evalEqn" [ "Merge expected a bool" ]+ in go alts+++ where+ done v = new { sValues = Map.insert x v (sValues new) }+ initialized s = s { sInitialized = Set.insert x (sInitialized s) }++ guarded = guardedOn c++ guardedOn cl s =+ case cl of+ BaseClock -> s+ WhenTrue a ->+ case evalAtom new a of+ VBool True -> guardedOn cl1 s+ where Just cl1 = clockParent env cl+ _ -> hold+ where hold = new { sValues = Map.insert x (evalVar old x) (sValues new) }++++++-- | Semantics of primitive operators.+evalPrimOp :: Op -> [Value] -> Value+evalPrimOp op vs =+ case op of+ Not ->+ case vs of+ [ VNil ] -> VNil+ [ VBool b ] -> VBool (not b)+ _ -> bad "1 bool"++ Neg ->+ case vs of+ [ VNil ] -> VNil+ [ VInt n ] -> VInt (negate n)+ [ VReal n ] -> VReal (negate n)+ _ -> bad "1 number"++ IntCast ->+ case vs of+ [ VNil ] -> VNil+ [ VReal r ] -> VInt (truncate r)+ _ -> bad "1 real"++ FloorCast ->+ case vs of+ [ VNil ] -> VNil+ [ VReal r ] -> VInt (floor r)+ _ -> bad "1 real"++ RealCast ->+ case vs of+ [ VNil ] -> VNil+ [ VInt n ] -> VReal (fromInteger n)+ _ -> bad "1 int"++ And ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VBool x, VBool y ] -> VBool (x && y)+ _ -> bad "2 bools"++ Or ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VBool x, VBool y ] -> VBool (x || y)+ _ -> bad "2 bools"++ Xor ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VBool x, VBool y ] -> VBool (x /= y)+ _ -> bad "2 bools"++ Implies ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VBool x, VBool y ] -> VBool (not x || y)+ _ -> bad "2 bools"++ Eq ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VBool x, VBool y ] -> VBool (x == y)+ [ VInt x, VInt y ] -> VBool (x == y)+ [ VReal x, VReal y ] -> VBool (x == y)+ _ -> bad "2 of the same type"++ Neq ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VBool x, VBool y ] -> VBool (x /= y)+ [ VInt x, VInt y ] -> VBool (x /= y)+ [ VReal x, VReal y ] -> VBool (x /= y)+ _ -> bad "2 of the same type"++ Lt ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VInt x, VInt y ] -> VBool (x < y)+ [ VReal x, VReal y ] -> VBool (x < y)+ _ -> bad "2 numbers"++ Leq ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VInt x, VInt y ] -> VBool (x <= y)+ [ VReal x, VReal y ] -> VBool (x <= y)+ _ -> bad "2 numbers"++ Gt ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VInt x, VInt y ] -> VBool (x > y)+ [ VReal x, VReal y ] -> VBool (x > y)+ _ -> bad "2 numbers"++ Geq ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VInt x, VInt y ] -> VBool (x >= y)+ [ VReal x, VReal y ] -> VBool (x >= y)+ _ -> bad "2 numbers"++ Add ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VInt x, VInt y ] -> VInt (x + y)+ [ VReal x, VReal y ] -> VReal (x + y)+ _ -> bad "2 numbers"++ Sub ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VInt x, VInt y ] -> VInt (x - y)+ [ VReal x, VReal y ] -> VReal (x - y)+ _ -> bad "2 numbers"++ Mul ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VInt x, VInt y ] -> VInt (x * y)+ [ VReal x, VReal y ] -> VReal (x * y)+ _ -> bad "2 numbers"++ Div ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VInt x, VInt y ] -> case eucledean_div_mod x y of+ Just (q,_) -> VInt q+ Nothing -> VNil -- ?+ [ VReal x, VReal y ] -> VReal (x / y)+ _ -> bad "2 numbers"++ Mod ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VInt x, VInt y ] -> case eucledean_div_mod x y of+ Just (_,r) -> VInt r+ Nothing -> VNil -- ?+ _ -> bad "2 ints"++ Power ->+ case vs of+ [ VNil, _ ] -> VNil+ [ _, VNil ] -> VNil+ [ VInt x, VInt y ] -> VInt (x ^ y)+ [ VReal x, VInt y ] -> VReal (x ^ y)+ _ -> bad "1 number and 1 int"++ ITE ->+ case vs of+ [ VNil, _, _ ] -> VNil+ [ VBool b, x, y ] -> if b then x else y -- should we check for Nil?+ _ -> bad "1 bool, and 2 of the same type"++ AtMostOne+ | any isNil vs -> VNil+ | Just bs <- mapM isBool vs -> VBool $ case filter id bs of+ _ : _ : _ -> False+ _ -> True+ | otherwise -> bad "all bool"++ Nor+ | any isNil vs -> VNil+ | Just bs <- mapM isBool vs -> VBool (not (or bs))+ | otherwise -> bad "all booleans"++ where+ bad y = panic "evalExpr" [ "Type error:"+ , "*** Operator: " ++ show op+ , "*** Expected: " ++ y+ , "*** Got: " ++ show vs ]++++++
+ Language/Lustre/Semantics/Value.hs view
@@ -0,0 +1,80 @@+{-# Language OverloadedStrings #-}+module Language.Lustre.Semantics.Value where++import Text.PrettyPrint as P+import Language.Lustre.Name+import Language.Lustre.AST+import Language.Lustre.Pretty++-- | The universe of basic values.+-- These are the values used for a specific time instance.+data Value = VInt !Integer+ | VBool !Bool+ | VReal !Rational+ | VEnum !OrigName !OrigName -- ^ Type, value+ | VStruct !OrigName ![Field Value] -- ^ Type, fields+ | VArray ![Value]+ deriving Show+++instance Eq Value where+ x == y =+ case (x,y) of+ (VInt a, VInt b) -> a == b+ (VBool a, VBool b) -> a == b+ (VReal a, VReal b) -> a == b+ (VEnum t1 a, VEnum t2 b) -> t1 == t2 && a == b+ (VArray as, VArray bs) -> cmpArr as bs+ (VStruct t1 as, VStruct t2 bs) | t1 == t2 -> cmpStr as bs+ _ -> False -- Type error++ where+ cmpArr as bs =+ case (as,bs) of+ ([],[]) -> True+ (a : xs, b : ys) -> a == b && cmpArr xs ys+ _ -> False++ cmpStr as bs =+ case (as,bs) of+ ([],[]) -> True+ (Field f v:more, fs) ->+ case getField f fs of+ Nothing -> False+ Just (v2,fs') -> v == v2 && cmpStr more fs'+ _ -> False -- Malformed structs++ getField nm fs =+ case fs of+ [] -> Nothing+ Field f a : more -> if nm == f+ then Just (a,more)+ else do (a',more') <- getField nm more+ return (a', Field f a : more')++++-- | The evaluation monad.+type EvalM = Either Error+type Error = String++-- | Crash evaluation. We'd like to avoid calls to this.+crash :: String -> String -> EvalM a+crash x y = Left (x ++ ": " ++ y)++typeError :: String -> String -> EvalM a+typeError x y = crash x ("Type error, expected " ++ y)+++--------------------------------------------------------------------------------++instance Pretty Value where+ ppPrec _ val =+ case val of+ VInt n -> integer n+ VBool b -> text (show b)+ VReal r -> double (fromRational r) -- XXX+ VEnum _ a -> pp a+ VStruct _ fs -> braces (commaSep (map pp fs))+ VArray vs -> brackets (hsep (punctuate comma (map pp vs)))+
+ Language/Lustre/Transform/Inline.hs view
@@ -0,0 +1,455 @@+{-# Language OverloadedStrings, GeneralizedNewtypeDeriving, DataKinds #-}++{- | This module inlines all functions at their call sites.+Assumptions:+ * Functions have been named, so they only appear at the top-level+ if equations.(see nameCallSites in NoStatic)+ * Top-level instance have been expaned (see expandNodeInsts in NoStatic)+ * Equations contan only simple (i.e., 'LVar') 'LHS's.+ * No constants+-}+module Language.Lustre.Transform.Inline+ (inlineCalls, AllRenamings, Renaming(..)) where++import Data.Map (Map)+import qualified Data.Map as Map+import MonadLib+import Data.Traversable(for)++import Language.Lustre.Name+import Language.Lustre.AST+import Language.Lustre.Monad+import Language.Lustre.Pretty+import Language.Lustre.Panic+import Language.Lustre.Utils++-- | Inline the calls from the given top declarations. Resturns information+-- about how things got renames, as well as new list of declarations.+inlineCalls :: [NodeDecl] {- ^ Already inline decls from environment -} ->+ [TopDecl] {- ^ More decls to process -} ->+ LustreM (AllRenamings,[TopDecl])+inlineCalls ini ds = runInM ini (mapM inlineDecl ds)+++{- The plan:++Given:++node f (a : A; b : B) returns (c : C; d : D)+ var e : E;+let+ e = e3+ c = e4+ d = e5+ assume e6+ show e7+ GLOBAL assume e8+tel+++And a use site within some node `g`:++node g (...) returns (..)+ var ...++let+ ...+ x,y = f ((e1,e2) when t)+ ...+tel++Transform `g` as follows:++1. Compute name renaming:+ a -> a1 -- choose non-clashing names inputs+ b -> b1 -- ditto+ e -> e1 -- choose non-clashing name for locals+ c -> x -- match output with LHS+ d -> y -- ditto+++2. New definition of `g`:++node g(...) returns (...)+ var ...+ var a1 when t : A; -- non-clashing names for params+ var b1 when t : B; -- non-clashing names for params+ var e1 when t : E; -- non-clashing names for locals+let+ ...+ a1 = e1 -- renamed params+ a2 = e2 -- ditto+ e1 = e3 [renaming]+ x = e4 [renaming]+ y = e5 [renaming]+ show (e6 [renaming]) -- prove that concrete values match expectations+ args_ok = e6[renaming] and ... others ...+ show (args_ok => e7 [renaming])+ -- note: no polarity switching, but we assume that inputs were OK+ -- this ensure that the spec on `f` was OK+ GLOBAL assume e8[renaming]+ -- no plarity switchin on global assumptions, as these are assumptions+ -- about the environment that we just inheirt in our spec.+++3. Modular Reasoning++Consider:+ f (x : real) returns (y : real)+ let+ assume e1+ show e2+ tel++Sometimes we may want to construct a proof which *assumes* that `f`+is working correctly. In that case, we translate `g` a bit different:++node g(...) returns (...)+ var ...+ var a1 when t : A; -- non-clashing names for params+ var b1 when t : B; -- non-clashing names for params+let+ ...+ a1 = e1 -- renamed params+ a2 = e2 -- ditto+ -- no definitions for results+ show (e6 [renaming]) -- prove that concrete values match expectations+ args_ok = e6[renaming] and ... others ...+ GLOBAL assume (args_ok => e7 [renaming])++ NOTE: this assumes that guarantees do not mention any local variables.+ if they do, then we'd have to also add the definitions of those variables.+ ...+-}+++-- | Change the name of a binder to avoid name clasehs.+freshBinder :: Binder -> InM Binder+freshBinder b = do n <- freshName (binderDefines b)+ pure b { binderDefines = n }+++-- | A mapping from old names to their clash-avoiding versions.+data Renaming = Renaming+ { renVarMap :: Map OrigName OrigName+ -- ^ Mapping of names.++ , renClock :: IClock+ -- ^ Clock at the call site, if any.+ -- If this is set, then we have to replace base clocks with this clock+ -- in the inlined code.+ }+++-- | Compute the renaming to be used when instantiating the given node.+computeRenaming ::+ IClock {- ^ Clock at the call site -} ->+ [LHS Expression] {- ^ LHS of call site -} ->+ NodeDecl {- ^ Function being called -} ->+ InM (Renaming, [LocalDecl], [OrigName])+ -- ^ renaming of identifiers, new locals to add+ -- Last result is a "call site id", which is used for showing traces+ -- (i.e., a kind of inverse)+computeRenaming cl lhs nd =+ do newBinders <-+ for oldBinders $ \b ->+ do n <- freshBinder b+ pure $ case cl of+ BaseClock -> n -- still need to apply subst to clocks+ KnownClock c ->+ case cClock (binderType n) of+ BaseClock ->+ let ct = binderType n+ in n { binderType = ct { cClock = KnownClock c } }+ KnownClock _ -> n -- still need to apply su+ ClockVar i -> panic "computeRenaming"+ [ "Unexpected clock variable", showPP i ]++ ClockVar i -> panic "computeRenaming"+ [ "Unexpected clock variable", showPP i ]++ let renaming = Renaming+ { renVarMap = Map.fromList $+ zipExact renOut (nodeOutputs prof) lhs +++ zipExact renBind oldBinders newBinders+ , renClock = cl+ }+ renB b = b { binderType = rename renaming (binderType b) }+ pure (renaming, map (LocalVar . renB) newBinders, map lhsIdent lhs)+ where+ prof = nodeProfile nd+ def = case nodeDef nd of+ Just b -> b+ Nothing -> panic "computeRenaming"+ [ "The node has no definition."+ , "*** Node: " ++ showPP nd ]+++ oldBinders = map inputBinder (nodeInputs prof) +++ map localBinder (nodeLocals def)++ lhsIdent l = case l of+ LVar i -> identOrigName i+ _ -> panic "computeRenaming"+ [ "LHS is not a simple identifier."+ , "*** LHS: " ++ showPP l ]++ renOut b l = (identOrigName (binderDefines b), lhsIdent l)+ renBind old new = ( identOrigName (binderDefines old)+ , identOrigName (binderDefines new)+ )+++inputBinder :: InputBinder -> Binder+inputBinder ib =+ case ib of+ InputBinder b -> b+ InputConst i t -> panic "inputBinder"+ [ "Unexpected constant parameter."+ , "Constants should have been eliminated by now."+ , "*** Name: " ++ showPP i+ , "*** Type: " ++ showPP t ]++localBinder :: LocalDecl -> Binder+localBinder l = case l of+ LocalVar b -> b+ LocalConst cd ->+ panic "localBinder"+ [ "Unexpected local constant."+ , "Constants should have been eliminated by now."+ , "*** Constant: " ++ showPP cd+ ]++++--------------------------------------------------------------------------------+-- Applying a renaming, used when instantiatiating inlined functions.++-- | We don't visit constant expressions, as they should contain no variables+-- by this stage (i.e., they ought to be constant values).+class Rename t where+ rename :: Renaming -> t -> t++instance Rename a => Rename [a] where+ rename su xs = rename su <$> xs++instance Rename a => Rename (Maybe a) where+ rename su xs = rename su <$> xs++instance Rename Ident where+ rename su i = case Map.lookup (identOrigName i) (renVarMap su) of+ Just n -> origNameToIdent n+ Nothing -> i++instance Rename Name where+ rename su x = case Map.lookup (nameOrigName x) (renVarMap su) of+ Just n -> origNameToName n+ Nothing -> x++instance Rename Expression where+ rename su expr =+ case expr of+ ERange r e -> ERange r (rename su e)+ Const e t -> Const e (rename su t)+ Var x -> Var (rename su x)+ Lit _ -> bad "literal, not under Const"++ e `When` ce -> rename su e `When` rename su ce++ Merge i ms -> Merge (rename su i) (rename su ms)+ Call ni es c mTys -> Call ni (rename su es) (rename su c) (rename su mTys)++ Tuple {} -> bad "tuple"+ Array {} -> bad "array"+ Select {} -> bad "select"+ Struct {} -> bad "struct"+ UpdateStruct {} -> bad "struct update"+ WithThenElse {} -> bad "with-then-else"+ where+ bad x = panic "rename" [ "Unexepected " ++ x ]++instance Rename e => Rename (Field e) where+ rename su (Field l e) = Field l (rename su e)++instance Rename ClockExpr where+ rename su (WhenClock r e i) = WhenClock r e (rename su i)++instance Rename CType where+ rename su ct = ct { cClock = rename su (cClock ct) }++instance Rename IClock where+ rename su clk =+ case clk of+ BaseClock -> renClock su+ KnownClock c -> KnownClock (rename su c)+ ClockVar {} -> panic "Inline.rename" [ "Unexpected clock variable." ]++instance Rename e => Rename (MergeCase e) where+ rename su (MergeCase a b) = MergeCase a (rename su b)+++instance Rename a => Rename (LHS a) where+ rename su lhs =+ case lhs of+ LVar b -> LVar (rename su b)+ LSelect {} -> panic "rename" [ "Unexepected LHS select" ]++instance Rename Equation where+ rename su eqn =+ case eqn of+ Assert x ty e -> Assert x ty (rename su e) -- XXX: change names?+ Property x e -> Property x (rename su e) -- XXX: change names?+ IsMain r -> IsMain r+ Define ls e -> Define (rename su ls) (rename su e)+ IVC is -> IVC (rename su is)+ Realizable is -> Realizable (rename su is)++--------------------------------------------------------------------------------++-- | Inline the "normal" calls in a node declaration.+-- We assume that the calls in the definition have been already inlined,+-- so we don't continue inlining recursively.+inlineCallsNode ::+ NodeDecl -> InM (Map [OrigName] (OrigName,Renaming), NodeDecl)+inlineCallsNode nd =+ case nodeDef nd of+ Nothing -> pure (Map.empty,nd)+ Just def+ | null (nodeStaticInputs nd) ->+ do ready <- doneNodes+ (newLocs,newEqs,rens) <- renameEqns ready (nodeEqns def)+ pure ( rens+ , nd { nodeDef = Just NodeBody+ { nodeLocals = newLocs ++ nodeLocals def+ , nodeEqns = newEqs+ } }+ )++ | otherwise ->+ panic "inlineCalls" [ "Unexpected static arguments."+ , "*** Node: " ++ showPP nd ]++ where+ isCall e =+ case e of+ ERange _ e1 -> isCall e1+ Call (NodeInst (CallUser f) []) es cl _ -> Just (f,es,cl)+ _ -> Nothing++ renameEqns ready eqns =+ case eqns of+ [] -> pure ([],[],Map.empty)+ eqn : more ->+ case eqn of+ Define ls e+ | Just (f,es,cl) <- isCall e+ , let fo = nameOrigName f+ , Just cnd <- Map.lookup fo ready+ , Just def <- nodeDef cnd ->+ do let prof = nodeProfile cnd+ (su, newLocals, key) <- computeRenaming cl ls cnd+ let paramDef b p = Define [LVar (rename su (binderDefines b))] p+ paramDefs = zipExact paramDef+ (map inputBinder (nodeInputs prof)) es+ thisEqns = updateProps (nodeExtern cnd)+ (rename su (nodeEqns def))+ (otherDefs,otherEqns,rens) <- renameEqns ready more+ pure ( newLocals ++ otherDefs+ , paramDefs ++ thisEqns ++ otherEqns+ , Map.insert key (fo,su) rens+ )++ _ -> do (otherDefs, otherEqns, rens) <- renameEqns ready more+ pure (otherDefs, eqn : otherEqns, rens)++ updateProps extern eqns =+ let asmps = [ e | Assert _ AssertPre e <- eqns ]++ boolTy = CType BoolType BaseClock++ addAsmps e1 = case asmps of+ [] -> e1+ [a] -> eOp2 (range e1) Implies a e1 (Just [boolTy])+ as -> eOp2 (range e1) Implies+ (foldr1 (\a b -> eOp2 (range e1) And a b (Just [boolTy])) as)+ e1+ (Just [boolTy])+ upd eqn = case eqn of+ Assert x ty e ->+ case ty of+ AssertPre -> Property x e+ AssertEnv -> Assert x AssertEnv e++ Property x e+ | extern -> Assert x AssertEnv (addAsmps e)+ | otherwise -> Property x (addAsmps e)+ _ -> eqn+ in map upd eqns++inlineDecl :: TopDecl -> InM TopDecl+inlineDecl d =+ case d of+ DeclareNode nd ->+ do (thisRens,nd1) <- inlineCallsNode nd+ addNodeDecl thisRens nd1+ pure (DeclareNode nd1)+ _ -> pure d++--------------------------------------------------------------------------------+-- Resugar++-- | Maps (node name, call_site as list of name, function called, renamed)+-- XXX: Identifying call sites by something other than list of ids.+type AllRenamings = Map OrigName {-node name-} (+ Map [OrigName] {-call site-}+ ( OrigName {-called node-}+ , Renaming {-how names changed, and we called-}+ )+ )++--------------------------------------------------------------------------------++newtype InM a = InM { unInM :: StateT RW LustreM a }+ deriving (Functor,Applicative,Monad)++data RW = RW+ { inlinedNodes :: !(Map OrigName NodeDecl)+ -- ^ Nodes that have been processed already.++ , renamings :: AllRenamings+ -- ^ How we renamed things, for propagating answers back.+ }++runInM :: [NodeDecl] -> InM a -> LustreM (AllRenamings, a)+runInM ini m =+ do (a,s1) <- runStateT s $ unInM m+ pure (renamings s1, a)+ where+ s = RW { inlinedNodes = Map.fromList (map entry ini)+ , renamings = Map.empty+ }+ entry nd = (identOrigName (nodeName nd), nd)++-- | Add an inlined node to the collection of processed nodes.+addNodeDecl ::+ Map [OrigName] (OrigName,Renaming) {- ^ Info about inlined vars -} ->+ NodeDecl {- ^ Inlined function -} ->+ InM ()+addNodeDecl rens nd = InM $+ sets_ $ \s -> s { inlinedNodes = Map.insert i nd (inlinedNodes s)+ , renamings = Map.insert i rens (renamings s) }+ where i = identOrigName (nodeName nd)++doneNodes :: InM (Map OrigName NodeDecl)+doneNodes = InM $ inlinedNodes <$> get++{- | Generate a new version of the given identifier. -}+freshName :: Ident -> InM Ident+freshName i =+ do u <- InM (inBase newInt)+ let newON = (identOrigName i) { rnUID = u }+ pure i { identResolved = Just newON }++++
+ Language/Lustre/Transform/NoStatic.hs view
@@ -0,0 +1,1321 @@+{-# Language OverloadedStrings, DataKinds #-}+{-| NOTE: At the moment the transformation in this pass are not really+optional, as the following passes expect them.++XXX: This is quite complex, and it should probably be split into+the code that names call sites, and the code that actually instantiates+static parameters.++This module removes static arguments and constants.+Calls to functions with static arguments are lifted to the top-level+and given an explicit name.++Optionally (flag 'expandNodeInstDecl'), we can also expand functions+applied to static arguments to functions using a specialized definition instead.++Optionally (flag 'nameCallSites), we can add explicit names for nested call+sites. For example, if @f(x,y)@ is a call that appears somewhere in an+expression, we add a new equation:++p,q,r = f (x,y)++and replace the function call with @(p,q,r)@.++This will help with the following transformations:++ 1. when removing structured data, it is convenient if structured data is+ either explicit or a variable: we can work around that for "simple"+ expressions such as "when" and "merge", however we don't want to+ duplicate function calls, so naming them is useful.++ 2. if function calls are named, it should be simpler to inline the+ function's definition, as we can use the equations from `f` to+ define `p`, `q`, and `r`.++NOTE: We do NOT name calls to primitives that return a single result+(e.g., +, #, |, or ITE)+-}++module Language.Lustre.Transform.NoStatic+ ( noConst+ , CallSiteMap+ , CallSiteId, idFromRange, callSiteName+ ) where++import Data.Function(on)+import Data.Either(partitionEithers)+import Data.Map(Map)+import Data.Foldable(foldl')+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as Text+import MonadLib hiding (Label)+import Text.PrettyPrint(punctuate,comma,hsep)++import Language.Lustre.Name+import Language.Lustre.AST+import Language.Lustre.Monad+import qualified Language.Lustre.Semantics.Const as C+import Language.Lustre.Semantics.Const (valToExpr)+import Language.Lustre.Semantics.Value+import Language.Lustre.Panic(panic)+import Language.Lustre.Pretty++-- | Currently assumes an empty environment.+noConst :: [TopDecl] -> LustreM (CallSiteMap, [TopDecl])+noConst ds =+ do seed <- getNameSeed+ let env = evalTopDecls (emptyEnv seed)+ { expandNodeInsts = True+ , nameCallSites = True+ , envCurMod = Nothing+ } ds+ setNameSeed (envNameInstSeed env)+ pure (envCallSiteMap env, reverse (readyDecls env))+++-- | Evaluate a top-level declaration.+evalTopDecl :: Env -> TopDecl -> Env+evalTopDecl env td =+ case td of+ DeclareType tde -> evalTypeDecl env tde+ DeclareConst cd -> evalConstDef env cd+ DeclareNode nd -> evalNodeDecl env nd+ DeclareNodeInst nid -> evalNodeInstDecl env nid+ DeclareContract {} ->+ panic "evalTopDecl"+ [ "Declaring top-level contracts is not yet supported." ]++-- | Evaluate multiple top-level declarations from the same modeule.+evalTopDecls :: Env -> [TopDecl ] -> Env+evalTopDecls = foldl' evalTopDecl+++-- | Maps node definitions to the places in the source where they are called.+-- For each call, we keep track of the left-hand-sides storing the results+-- of the call.+type CallSiteMap = Map OrigName (Map CallSiteId [LHS Expression])++-- | Identifies a call site uniquely.+-- Currently, it is computed from the location in the source.+-- XXX: Needs to be augmented to support multiple files/modules.+data CallSiteId = CallSiteId { csId :: (Int,Int), csRange :: SourceRange }+ deriving (Show)++-- | An identifer for a call site. This is computed from the location in the+-- source and so it should be unique wrt to a file, but not when multiple+-- file are involved.+callSiteName :: CallSiteId -> String+callSiteName x = "cs_" ++ show a ++ "_" ++ show b+ where (a,b) = csId x++instance HasRange CallSiteId where+ range = csRange++instance Eq CallSiteId where+ (==) = (==) `on` csId++instance Ord CallSiteId where+ compare = compare `on` csId++-- | This ignores files, so it only makes sense for ranges in the same file.+idFromRange :: SourceRange -> CallSiteId+idFromRange r = CallSiteId { csId = (pos sourceFrom, pos sourceTo)+ , csRange = r }+ where+ pos f = sourceIndex (f r)+++--------------------------------------------------------------------------------+-- Evaluation Context and State++++data Env = Env++ { cEnv :: C.Env+ -- ^ Environment for evaluating constants.++ , nodeInfo :: Map OrigName NodeProfile+ -- ^ Types of the nodes that are in scope.+ -- This is used to determine how to name the call sites.+ -- It is also used to figure out which parameters are constants+ -- when we call a function.++ , nodeTemplates :: Map OrigName TopDecl+ -- ^ Nodes with static parameters, used when we expand definitions.+ -- These declarations are NOT evaluated, instead we make a new copy+ -- for each instantiation.++ , typeAliases :: Map OrigName Type+ -- ^ Maps type names to evaluated types.+ -- The only named types in an evaluated type are either structs or enums,+ -- there should be no aliases to other types.+ -- We also use this field when we are instantiating a node parameterized+ -- by a type: the type parameters go in this map, temporarily.++ , envCurMod :: Maybe ModName+ -- ^ Use this in the original name, when generating fresh top-level names.+ -- (e.g., for naming instantiate things, or call sites).++ , expandNodeInsts :: Bool+ {- ^ Should we expand node instances, or leave them named at the+ top level. Note that we don't do any sharing at the moment,+ so multiple identical instantiations would be simply copies+ of each other.+ NOTE: Later passes assumes that this is True+ -}++ , nameCallSites :: Bool+ {- ^ Should we add explicit equations for each call site?+ NOTE: Later passes assume that this is True+ -}++ , envNameInstSeed :: !NameSeed+ -- ^ For generating names for function instantiations (not-expanded)++ , envCurRange :: Maybe SourceRange+ -- ^ Whereabouts are we++ , readyDecls :: [TopDecl]+ -- ^ Declarations that we've already processed.+ -- These are the output of the algorithm.++ , nodeArgs :: Map OrigName NodeInst+ -- ^ Instantiated node arguments: if the node argument was an instantiation,+ -- then we first instantiate the template, give it a name, and use+ -- that name. So, we should never have any remaining static+ -- arguments.+++ , envCallSiteMap :: CallSiteMap+ {- ^ For each node, maps a range in the source to a call site.+ The call site is identified by the variables storing the results+ of the call. This is useful so that we can propagate results from+ later passes back to the calls they correspond to.+ -}++ }++inRange :: SourceRange -> Env -> Env+inRange r env = env { envCurRange = Just r }+++-- | Does not expand node instances+emptyEnv :: NameSeed -> Env+emptyEnv seed =+ Env { cEnv = C.emptyEnv+ , nodeInfo = Map.empty+ , typeAliases = Map.empty+ , nodeTemplates = Map.empty+ , readyDecls = []+ , nodeArgs = Map.empty+ , expandNodeInsts = False+ , nameCallSites = False+ , envNameInstSeed = seed+ , envCurRange = Nothing+ , envCallSiteMap = Map.empty+ , envCurMod = Nothing+ }++lookupNodeTemplateInfo ::+ OrigName -> Env -> Maybe ([StaticParam], Either NodeProfile NodeInst)+lookupNodeTemplateInfo x env =+ do temp <- Map.lookup x (nodeTemplates env)+ case temp of+ DeclareNode nd -> pure ( nodeStaticInputs nd ++ getConstParams p+ , Left p+ )+ where p = nodeProfile nd++ DeclareNodeInst nid ->+ pure (nodeInstStaticInputs nid, Right (nodeInstDef nid))+ it -> panic "lookupNodeTemplateInfo"+ [ "Unexpected template for " ++ showPP x+ , "*** Declaration:"+ , showPP it+ ]++getConstParams :: NodeProfile -> [ StaticParam ]+getConstParams p = [ ConstParam i t | InputConst i t <- nodeInputs p ]+++--------------------------------------------------------------------------------+-- Evaluation of types++-- | Evaluate a type declaration.+evalTypeDecl :: Env -> TypeDecl -> Env+evalTypeDecl env td =+ case typeDef td of+ Nothing -> panic "evalTypeDecls" [ "Unsupported abstract type:"+ , "*** Name: " ++ showPP name+ ]+ Just tdef ->+ case tdef of+ IsType x -> addAlias env name (evalType env x)++ -- Add the enumeration constants to the constant environemnt.+ IsEnum xs -> env { cEnv = update (cEnv env) }+ where+ update cenv =+ cenv { C.envConsts = foldr addVal (C.envConsts cenv) xs }+ addVal i = let nm = identOrigName i+ in Map.insert nm (VEnum name nm)++ IsStruct xs ->+ env { cEnv = update (cEnv env)+ , readyDecls = DeclareType td { typeDef = Just (IsStruct ds) }+ : readyDecls env+ }+ where+ update cenv =+ cenv { C.envStructs = Map.insert name fs (C.envStructs cenv) }++ (fs,ds) = unzip (map doField xs)++ doField x =+ ( (fieldName x, evalExprToVal env <$> fieldDefault x)++ , x { fieldType = evalType env (fieldType x)+ , fieldDefault = Nothing+ }+ )++ where+ name = identOrigName (typeName td)++++-- | Evaluate a type: resolves named types, and evaluates array sizes.+evalType :: Env -> Type -> Type+evalType env ty =+ case ty of+ TypeRange r t -> TypeRange r (evalType env t)++ ArrayType t e -> ArrayType (evalType env t) (evalIntExpr env e)++ IntSubrange e1 e2 -> IntSubrange (evalIntExpr env e1) (evalIntExpr env e2)++ -- XXX: Note that the locations in the expanded type will be those+ -- of the definition site, not the ones at the use site.+ NamedType n -> case Map.lookup (nameOrigName n) (typeAliases env) of+ Just t1 -> t1+ Nothing -> NamedType n++ IntType -> IntType+ RealType -> RealType+ BoolType -> BoolType+++-- | Add a new name for the given type. If the named type is a struct,+-- then also add appropriate entries to the other maps,+-- so we can do direct look-ups without having to consult the alias map.+addAlias :: Env -> OrigName -> Type -> Env+addAlias env x t =+ case t of+ NamedType n ->+ case checkEnum `mplus` checkStruct of+ Just env2 -> env2+ Nothing -> panic "addAlias"+ [ "Named type is neither `enum`, nor `struct`:"+ , "*** Name: " ++ showPP n+ ]+ where+ checkEnum = pure env1++ checkStruct =+ do let cenv = cEnv env+ i <- Map.lookup (nameOrigName n) (C.envStructs cenv)+ let newMap = Map.insert x i (C.envStructs cenv)+ pure env1 { cEnv = cenv { C.envStructs = newMap } }++ _ -> env1+ where+ env1 = env { typeAliases = Map.insert x t (typeAliases env) }+++++--------------------------------------------------------------------------------+-- Evaluation of constants++-- | Evaluate the definition of a constant, adding its values to the+-- environment.+evalConstDef :: Env -> ConstDef -> Env+evalConstDef env cd = env { cEnv = newCEnv }+ where+ cenv = cEnv env+ val = case constDef cd of+ Just e -> evalExprToVal env e+ Nothing -> panic "evalConstDef"+ [ "Uninterpreted constants are not supported."+ , "*** Name: " ++ showPP (constName cd)+ ]++ newCEnv = cenv { C.envConsts = Map.insert name val (C.envConsts cenv) }+ name = identOrigName (constName cd)++++-- | Evaluate a constant expression of integer type.+evalIntExpr :: Env -> Expression -> Expression+evalIntExpr env expr =+ case expr of+ ERange r e -> ERange r (evalIntExpr (inRange r env) e)+ _ -> case C.evalIntConst (cEnv env) expr of+ Right i -> Lit (Int i)+ Left err -> panic "evalIntExpr" [err]++-- | Evaluate a constant expression to a value.+evalExprToVal :: Env -> Expression -> Value+evalExprToVal env expr =+ case expr of+ ERange r e -> evalExprToVal (inRange r env) e+ _ -> case C.evalConst (cEnv env) expr of+ Right val -> val+ Left err -> panic "evalExprToVal" [err]++-- | Evaluate a constant expression.+evalExpr :: Env -> Expression -> Expression+evalExpr env expr =+ case expr of+ ERange r e -> ERange r (evalExpr (inRange r env) e)+ _ -> valToExpr (evalExprToVal env expr)+++-- | Evaluate a selector. The indixes in a selector are constants.+evalSel :: Env -> Selector Expression -> Selector Expression+evalSel env sel =+ case sel of+ SelectField i -> SelectField i+ SelectElement e -> SelectElement (evalIntExpr env e)+ SelectSlice s -> SelectSlice (evalSlice env s)+++-- | Eval an array slice. The indexes in the slice are constants.+evalSlice :: Env -> ArraySlice Expression -> ArraySlice Expression+evalSlice env s = ArraySlice { arrayStart = evalIntExpr env (arrayStart s)+ , arrayEnd = evalIntExpr env (arrayEnd s)+ , arrayStep = evalIntExpr env <$> arrayStep s+ }++-- | Evaluate a clock expression. The value activating the clock+-- is a constnat, and the identifier is definatly not.+evalClockExpr :: Env -> ClockExpr -> ClockExpr+evalClockExpr env (WhenClock r e i) = WhenClock r (evalExpr env e) i++evalCType :: Env -> CType -> CType+evalCType env ct = CType { cType = evalType env (cType ct)+ , cClock = evalIClock env (cClock ct)+ }++evalIClock :: Env -> IClock -> IClock+evalIClock env clk =+ case clk of+ BaseClock -> BaseClock+ KnownClock c -> KnownClock (evalClockExpr env c)+ ClockVar {} -> panic "NoStatic.evalIClock" [ "Unexpected clock variable." ]++++--------------------------------------------------------------------------------+-- Evaluation of Nodes+++{- | Evaluate a node declaration.+Nodes with static parameters are added to the template map, while "normal"+nodes are evaluated and added to the declaration list. -}+evalNodeDecl :: Env -> NodeDecl -> Env+evalNodeDecl env nd =+ case nodeStaticInputs nd ++ getConstParams (nodeProfile nd) of+ [] -> evalNode env nd []+ ps -> env { nodeTemplates = Map.insert name (DeclareNode nd)+ (nodeTemplates env)+ , nodeInfo = Map.insert name (nodeProfile nd) (nodeInfo env)+ }+ where+ name = identOrigName (nodeName nd)+++-- | Evaluate and instantiate a node with the given static parameters.+-- We assume that the arguments have been evaluated already.+evalNode :: Env -> NodeDecl -> [StaticArg] -> Env+evalNode env nd args =+ envRet2 { readyDecls = DeclareNode newNode : readyDecls envRet2+ , nodeInfo = Map.insert name newProf (nodeInfo envRet2)+ }+ where+ name = identOrigName (nodeName nd)++ -- 1. bind the provided static arguments.+ env0 = addStaticParams (nodeStaticInputs nd) args env+ newProf = evalNodeProfile env0 (nodeProfile nd)++ -- 2. evaluate constants in the locals+ (bs,env1) = evalLocalDecls env0 $ case nodeDef nd of+ Nothing -> []+ Just body -> nodeLocals body++ -- 3. "blackhole" the name seed, which should not be used.+ -- This a strict field, so we can't put a panic there, so instead+ -- we just make up a very invalid value, which would hopefully be+ -- easy to spot, in case it get used accidentally.+ env2 = env1 { envNameInstSeed = invalidNameSeed 77 }++ -- 4. Evaluate the equations in the body of a node.+ ((eqs,ctr),newLs,insts,info,newS) =+ runNameStatic (envNameInstSeed env)+ (envCurMod env) $+ do newCtr <- traverse (evalContract env2) (nodeContract nd)+ -- XXX: here we assume that locals are in scope in the contract?+ -- also, function calls in the contract become ordinary locals,+ -- instead of ghost variables, and we may want to distinguish+ -- between this (e.g., if generating code).++ newEqs <- case nodeDef nd of+ Nothing -> pure []+ Just body -> traverse (evalEqn env2) (nodeEqns body)+ pure (concat newEqs, newCtr)++ -- Results, updating the *original* environment.+ envRet1 = env { envNameInstSeed = newS+ , envCallSiteMap = Map.insert name info (envCallSiteMap env)+ }+ envRet2 = addEvaluatedNodeInsts envRet1 insts+++ newDef = case nodeDef nd of+ Nothing -> Nothing+ Just _ -> Just NodeBody+ { nodeLocals = map LocalVar (newLs ++ bs)+ , nodeEqns = eqs+ }++ newNode = nd { nodeStaticInputs = []+ , nodeProfile = newProf+ , nodeContract = ctr+ , nodeDef = newDef+ }+++++-- | Evaluate a binder.have been evaluated already.+evalBinder :: Env -> Binder -> Binder+evalBinder env b = b { binderType = evalCType env (binderType b) }+++-- | Evaluate the binders in the type of a node.+evalNodeProfile :: Env -> NodeProfile -> NodeProfile+evalNodeProfile env np =+ NodeProfile { nodeInputs = map (evalInputBinder env) (nodeInputs np)+ , nodeOutputs = map (evalBinder env) (nodeOutputs np)+ }+++evalInputBinder :: Env -> InputBinder -> InputBinder+evalInputBinder env ib =+ case ib of+ InputBinder b -> InputBinder (evalBinder env b)+ InputConst i t -> panic "evalInputBinder"+ [ "Unexpected constant parameter."+ , "It should have been desugared by now."+ , "*** Name: " ++ showPP i+ , "*** Type: " ++ showPP t ]+++-- | Evaluate a bunch of locals: the constants are added to the environment,+-- and we get the binders for the variables.+evalLocalDecls :: Env -> [ LocalDecl ] -> ([Binder], Env)+evalLocalDecls env ds = ( [ evalBinder env1 b | LocalVar b <- ds ]+ , env1+ )+ where+ env1 = foldl' evalConstDef env [ c | LocalConst c <- ds ]+++evalContract :: Env -> Contract -> M Contract+evalContract env c =+ do cis <- mapM (evalContractItem env) (contractItems c)+ pure c { contractItems = cis }++evalContractItem :: Env -> ContractItem -> M ContractItem+evalContractItem env ci =+ case ci of+ Assume l e -> Assume l <$> evalDynExpr NestedExpr env e+ Guarantee l e -> Guarantee l <$> evalDynExpr NestedExpr env e+ _ -> panic "evalContractItem"+ [ "Unsupported contract iterm. For now just `assume`/`guarante`."]+{-+ GhostConst c mbT e -> GhostConst c + GhostVar b e ->+ Mode m as ts ->+ Import c is os ->+-}++-- | Evaluate an equation.+evalEqn :: Env -> Equation -> M [Equation]+evalEqn env eqn =+ collectFunEqns $+ case eqn of+ Assert x t e -> Assert x t <$> evalDynExpr NestedExpr env e+ Property x e -> Property x <$> evalDynExpr NestedExpr env e+ Define ls e -> let lhs = map (evalLHS env) ls+ in Define lhs <$> evalDynExpr (TopExpr lhs) env e+ IsMain r -> pure (IsMain r)+ IVC is -> pure (IVC is)+ Realizable is -> pure (Realizable is)++-- | Evaluate a left-hand-side of an equation.+evalLHS :: Env -> LHS Expression -> LHS Expression+evalLHS env lhs =+ case lhs of+ LVar x -> LVar x+ LSelect l s -> LSelect (evalLHS env l) (evalSel env s)+++--------------------------------------------------------------------------------+-- Evaluating and Expanding Node Instances++-- | Evaluate a node-instance declaration.+-- Parameterized ones are added to the template map.+evalNodeInstDecl :: Env -> NodeInstDecl -> Env+evalNodeInstDecl env nid =+ case nodeInstStaticInputs nid of+ [] -> evalNodeInst env nid []+ ps -> env { nodeTemplates = Map.insert name (DeclareNodeInst nid)+ (nodeTemplates env)+ }+ where+ name = identOrigName (nodeInstName nid)+++-- | Evaluate a node-instance declaration using the given static arguments.+-- The static arguments should have been evaluated already.+evalNodeInst :: Env -> NodeInstDecl -> [StaticArg] -> Env+evalNodeInst env nid args = addEvaluatedNodeInst envRet2 newInst+ where+ env0 = addStaticParams (nodeInstStaticInputs nid) args env+ env1 = env0 { envNameInstSeed = invalidNameSeed 78 }+ -- Do not use! Bogus value for sanity.+ -- (strict, so no error/undefined)++ nameNodeInstDef (NodeInst f as) =+ case as of+ [] | CallUser nm <- f+ , Just ni <- Map.lookup (nameOrigName nm) (nodeArgs env1) -> pure ni+ _ -> do bs <- mapM (evalStaticArg env1) as+ pure (NodeInst f bs)++ (newDef,[],insts,info,newS) = runNameStatic+ (envNameInstSeed env)+ (envCurMod env)+ (nameNodeInstDef (nodeInstDef nid))++ envRet1 = env { envNameInstSeed = newS+ , envCallSiteMap =+ let nm = identOrigName (nodeInstName nid)+ in Map.insert nm info (envCallSiteMap env) }+ envRet2 = addEvaluatedNodeInsts envRet1 insts++ -- Note that we leave the name as is because this is the right thing+ -- for nodes with no static parameters. If, OTOH, we are instantiating+ -- a template, then we've already put the correct name in the template.++ newInst = nid { nodeInstStaticInputs = []+ , nodeInstProfile = Nothing+ , nodeInstDef = newDef+ }+++++-- | Add an already evaluated node instance to the environment.+-- This is where we expand instances, if the flag in the environment is set.+addEvaluatedNodeInst :: Env -> NodeInstDecl -> Env+addEvaluatedNodeInst env ni+ | expandNodeInsts env = expandNodeInstDecl env ni+ | otherwise = doAddNodeInstDecl ni env++-- | Add an already evaluated node instance to the environment.+-- This is where we expand instances, if the flag in the environment is set.+addEvaluatedNodeInsts :: Env -> [NodeInstDecl] -> Env+addEvaluatedNodeInsts = foldl' addEvaluatedNodeInst++-- | Replace a previously evaluated node-instance with its expanded version+-- @f = g<<const 2>> --> node f(...) instantiated `g`@+expandNodeInstDecl :: Env -> NodeInstDecl -> Env+expandNodeInstDecl env nid =+ case nodeInstStaticInputs nid of+ [] ->+ case nodeInstDef nid of+ NodeInst (CallUser f) ps@(_ : _) ->+ case Map.lookup (nameOrigName f) (nodeTemplates env) of+ Just nt ->+ case nt of++ DeclareNode nd ->+ let prof = nodeProfile nd+ (cs,is') = inputBindersToParams (nodeInputs prof)+ prof' = prof { nodeInputs = is' }+ in evalNode env nd { nodeName = nodeInstName nid+ , nodeProfile = prof'+ , nodeStaticInputs =+ nodeStaticInputs nd ++ cs+ } ps++ DeclareNodeInst nd ->+ evalNodeInst env nd { nodeInstName = nodeInstName nid } ps++ _ -> panic "expandNodeInstDecl"+ [ "Non-node template:"+ , "*** template: " ++ showPP nt+ ]++ _ -> panic "expandNodeInstDecl" $+ [ "Unknown template:"+ , "*** Name: " ++ showPP f+ , "*** Available: "+ ] ++ [ " " ++ showPP x+ | x <- Map.keys (nodeTemplates env) ]++ _ -> doAddNodeInstDecl nid env++ _ -> panic "expandNodeInstDecl"+ [ "Trying to expand a template!"+ , "*** Name: " ++ showPP (nodeInstName nid)+ ]++++-- expandIterAt :: Env -> [Binder] -> Iter -> [StaticArg] ->+{-+expandIterAt env resTys it args = undefined+ case (it,args) of+ (IterFill, [ NodeArg _ _ni, sz ], [s]) -> undefined+ {- let s1, x1, y1 = ni s+ s2, x2, y2 = ni s1+ s3, x3, y3 = ni s2+ ...+ sN, xN, yN = ni s{N-1}+ in (sN, [ x1 .. xN ], [ y1 .. yN ]) -}++ (IterRed, [ NodeArg _ ni, sz ], (s : xs)) -> undefined+ {- let s1 = ni (s , x1, y1)+ s2 = ni (s1, x2, y2)+ ...+ sN = ni (s{N-1}, xN, Yn)+ in sN -}++ (IterFill, [ NodeArg _ ni, sz ], (s : xs)) -> undefined+ {- let s1, a1, b1 = ni (s, x1, y1)+ s2, a2, b2 = ni (s1, x2, y2)+ ...+ sN, aN, bN = ni (s{N-1}, xN, yN)+ in (sN, [ a1 .. aN ], [b1 .. bN]) -}+++ (IterMap, [ NodeArg _ ni, sz ], xs) -> undefined+ {- let a1, b1 = ni (x1,y1)+ a2, b2 = ni (x2,y2)+ ...+ aN, bN = ni (xN,yN)+ in ([a1..N], [b1..bN]) -}++ (IterBoolRed, [ i, j, n ], [xs]) -> undefined+ {- let n1 = if x1 then 1 else 0+ n2 = if x2 then n1 + 1 else n1 + ...+ nN = if xN then n{N-1} + 1 else n{N-1}+ in i <= nN && nN <= j+ -}+-}++++-- | Add a finished node instance declaration to the environment.+doAddNodeInstDecl :: NodeInstDecl -> Env -> Env+doAddNodeInstDecl ni env =+ env { readyDecls = DeclareNodeInst ni : readyDecls env+ , nodeInfo = case getNodeInstProfile env (nodeInstDef ni) of+ Just prof -> Map.insert name prof (nodeInfo env)+ Nothing -> nodeInfo env+ }+ where name = identOrigName (nodeInstName ni)+++--------------------------------------------------------------------------------+-- Typing of Node Instances+-- XXX: This should have happened in the type checker?++{- | Determine the type of a node instance.+Returns 'Maybe' because in some cases we can't determine the+(e.g. some primitives are polymorphic). We don't name the call sites+for such primitces. -}+getNodeInstProfile :: Env -> NodeInst -> Maybe NodeProfile+getNodeInstProfile env (NodeInst c as) =+ case c of+ CallUser f ->+ case as of+ [] -> case Map.lookup (nameOrigName f) (nodeInfo env) of+ Just a -> Just a+ Nothing -> panic "getNodeInstProfile"+ [ "Unknown profile for node:"+ , "*** Node name: " ++ showPP f+ ]+ _ -> case lookupNodeTemplateInfo (nameOrigName f) env of+ Just (ps,lrProf) ->+ let env1 = addStaticParams ps as env+ in case lrProf of+ Left prof -> Just (evalNodeProfile env1 prof)+ Right ni -> getNodeInstProfile env1 ni+ _ -> panic "getNodeInstProfile"+ [ "Unknown profile for parameterized node:"+ , "*** Node name: " ++ showPP f+ ]+++ CallPrim _ p ->+ case p of+ Iter it ->+ case it of+ IterFill ->+ case as of+ [ NodeArg _ ni, ExprArg n ] ->+ do prof <- getNodeInstProfile env ni+ case nodeOutputs prof of+ b : bs -> Just prof { nodeOutputs = b : map (toArr n) bs}+ _ -> bad+ _ -> bad++ IterRed ->+ case as of+ [ NodeArg _ ni, ExprArg n ] ->+ do prof <- getNodeInstProfile env ni+ case nodeInputs prof of+ b : bs -> Just prof+ { nodeInputs = b : map (toArrI n) bs }+ _ -> bad+ _ -> bad+++ IterFillRed ->+ case as of+ [ NodeArg _ ni, ExprArg n ] ->+ do prof <- getNodeInstProfile env ni+ case (nodeInputs prof, nodeOutputs prof) of+ (i:is,o:os) ->+ Just NodeProfile+ { nodeInputs = i : map (toArrI n) is+ , nodeOutputs = o : map (toArr n) os+ }++ _ -> bad+ _ -> bad+++ IterMap ->+ case as of+ [ NodeArg _ ni, ExprArg n ] ->+ do prof <- getNodeInstProfile env ni+ Just NodeProfile+ { nodeInputs = map (toArrI n) (nodeInputs prof)+ , nodeOutputs = map (toArr n) (nodeOutputs prof)+ }+ _ -> bad+++ IterBoolRed ->+ panic "getNodeInstProfile"+ [ "Not yet implemented, IterBoolRed" ]++ where+ setTy x f = x { binderType = let ct = binderType x+ in ct { cType = f (cType ct) } }+ toArr n x = setTy x (`ArrayType` n)+ toArrI n x =+ case x of+ InputBinder b -> InputBinder (setTy b (`ArrayType` n))+ InputConst i t -> InputConst i (ArrayType t n)++ bad = panic "getNodeInstProfile"+ [ "Unexpecetd iterator instantiation."+ , "*** Iterator: " ++ showPP it+ , "*** Arguments: " ++ show ( hsep $ punctuate comma+ $ map pp as )+ ]+ Op1 _ -> Nothing+ Op2 _ -> Nothing+ OpN _ -> Nothing+ ITE -> Nothing+++--------------------------------------------------------------------------------+-- Static Arguments++addStaticParams :: [ StaticParam ] -> [ StaticArg ] -> Env -> Env+addStaticParams ps as env =+ case (ps,as) of+ ([], []) -> env+ (p : ps1, a : as1) -> addStaticParams ps1 as1 (addStaticParam p a env)+ _ -> panic "addStaticParams" [ "Mismatch in static aruments" ]+++addStaticParam :: StaticParam -> StaticArg -> Env -> Env+addStaticParam p a env+ | ArgRange _ a1 <- a = addStaticParam p a1 env -- XXX: use location?+ | otherwise =+ case p of++ TypeParam i ->+ case a of+ TypeArg t ->+ env { typeAliases = Map.insert (identOrigName i) t+ (typeAliases env) }+ _ -> panic "addStaticParam"+ [ "Invalid static parameter:"+ , "*** Expected: a type for " ++ showPP i+ , "*** Got: " ++ showPP a+ ]+++ ConstParam i t ->+ case a of+ ExprArg e ->+ let cenv = cEnv env+ val = evalExprToVal env e+ in env { cEnv = cenv { C.envConsts = Map.insert+ (identOrigName i) val+ (C.envConsts cenv) } }+ _ -> panic "addStaticParam"+ [ "Invalid static parameter:"+ , "*** Expected: a constant for " +++ showPP i ++ " : " ++ showPP t+ , "*** Got: " ++ showPP a+ ]+++ NodeParam _ _ f prof ->+ case a of+ NodeArg _ ni ->+ let nm = identOrigName f+ in env { nodeArgs = Map.insert nm ni (nodeArgs env)+ , nodeInfo = Map.insert nm prof (nodeInfo env) }++ _ -> panic "addStaticParam"+ [ "Invalid static parameter:"+ , "*** Expected: a node for " ++ showPP f+ , "*** Got: " ++ showPP a+ ]+++++++--------------------------------------------------------------------------------+-- Evaluation of expressions+++-- | Keep track if we are at the top or nested, to determine+-- when we should name call sites.+data ExprLoc = TopExpr [LHS Expression] | NestedExpr++-- | Rewrite an expression that is not neccessarily constant.+evalDynExpr :: ExprLoc -> Env -> Expression -> M Expression+evalDynExpr eloc env expr =+ case expr of+ ERange r e -> ERange r <$> evalDynExpr eloc (inRange r env) e++ Const e t -> pure (Const (evalExpr env e) (evalCType env t))++ Var {} -> pure expr++ Lit _ -> panic "evalDynExpr" [ "Unexpected `Lit` outside `Const`" ]+++ e1 `When` e2 -> do e1' <- evalDynExpr NestedExpr env e1+ pure (e1' `When` evalClockExpr env e2)++ Tuple es -> Tuple <$> mapM (evalDynExpr NestedExpr env) es+ Array es -> Array <$> mapM (evalDynExpr NestedExpr env) es+ Select e s -> do e' <- evalDynExpr NestedExpr env e+ pure (Select e' (evalSel env s))+++ -- INVARIANT: the fields in a struct value are in the same order is+ -- in the declaration.+ Struct s fs -> evalNewStruct env s fs++ -- INVARIANT: the fields in a struct value are in the same order is+ -- in the declaration.+ UpdateStruct ~(Just s) e fs -> evalUpdExprStruct env s e fs++ WithThenElse e1 e2 e3 ->+ case evalExprToVal env e1 of+ VBool b -> if b then evalDynExpr eloc env e2+ else evalDynExpr eloc env e3+ v -> panic "evalDynExpr"+ [ "Decision in `with-then-else` is not a `bool`"+ , "*** Value: " ++ showPP (valToExpr v)+ ]++ Merge i ms ->+ case Map.lookup (identOrigName i) (C.envConsts (cEnv env)) of+ Just v -> evalMergeConst env v ms+ Nothing -> Merge i <$> mapM (evalMergeCase env) ms++ Call f es cl0 mTys ->+ do let cl = evalIClock env cl0+ (cs,es0) <-+ case f of+ NodeInst (CallUser c) _ ->+ let nm = nameOrigName c+ in case Map.lookup nm (nodeInfo env) of+ Just p -> pure (inputBindersToArgs (nodeInputs p) es)+ Nothing -> panic "evalDynExpr"+ [ "Missing node profile for function."+ , "*** Function: " ++ showPP c+ ]+ _ -> pure ([],es)+ es' <- do args <- mapM (evalDynExpr NestedExpr env) es0+ pure $ case args of+ [ e ] | Just xs <- isTuple e -> xs+ _ -> args+ ni <- case (f,cs) of+ (NodeInst c [],[]) ->+ pure $+ case c of+ CallUser i+ | Just ni <- Map.lookup (nameOrigName i) (nodeArgs env)+ -> ni++ _ -> NodeInst c []+ (NodeInst c as, _) ->+ nameInstance env (NodeInst c (as ++ cs))++ shouldName <- case eloc of+ TopExpr ls ->+ do case f of+ NodeInst (CallUser _) _ ->+ recordCallSite (range f) ls+ _ -> pure ()+ pure False+ NestedExpr -> pure (nameCallSites env)+ if shouldName+ then nameCallSite env ni es' cl mTys+ else pure (Call ni es' cl mTys)++ where+ isTuple e =+ case e of+ ERange _ e1 -> isTuple e1+ Tuple es -> Just es+ _ -> Nothing++++-- | Identify which of the inputs are really static constant parameters.+inputBindersToParams :: [InputBinder] -> ([StaticParam],[InputBinder])+inputBindersToParams = partitionEithers . map classify+ where+ classify ib = case ib of+ InputBinder _ -> Right ib+ InputConst i t -> Left (ConstParam i t)++inputBindersToArgs ::+ [InputBinder] -> [Expression] -> ([StaticArg],[Expression])+inputBindersToArgs ins es =+ case (ins,es) of+ ([],[]) -> ([],[])+ (i:is,e:rest) ->+ let (cs,vs) = inputBindersToArgs is rest+ in case i of+ InputBinder _ -> (cs,e:vs)+ InputConst {} -> (ExprArg e : cs,vs)+ _ -> panic "inputBindersToArgs" [ "Type argument mismatch in call."]+++++-- | Name a call site, by adding an additional equation for the call,+-- and replacing the call with a tuple containing the results.+-- We leave primitives with a single result as calls though.+nameCallSite ::+ Env -> NodeInst -> [Expression] -> IClock -> Maybe [CType] -> M Expression+nameCallSite env ni es cl mTys =+ do mb <- findInstProf env ni+ case mb of+ Just prof ->+ do let ins = map inB (nodeInputs prof)+ outs = nodeOutputs prof++ let baseName = Text.pack (show (pp ni))+ oName o = case outs of+ [_] -> baseName+ _ -> Text.concat+ [ baseName, "_", identText (binderDefines o) ]+ let newId o = do i <- newIdent (range ni) Nothing (oName o) AVal+ pure (origNameToIdent i)+ ns <- mapM newId outs+ let names = map binderDefines (ins ++ outs)+ let nameMap = Map.fromList+ $ zip names (map isIdent es ++ map Just ns)++ renClock (WhenClock r e i) = -- loc?+ WhenClock r (evalExpr env e) $+ case Map.lookup i nameMap of+ Just (Just j) -> j+ Just Nothing ->+ panic "nameCallSite"+ [ "Output's clock depends on an input." -- ?+ , "The clock parameter must be an identifier."+ , "*** Clock: " ++ showPP i+ ]+ _ -> panic "nameCallSite"+ [ "Undefined clock variable."+ , "*** Clock: " ++ showPP i ]++ toBind n b =+ Binder+ { binderDefines = n+ , binderType =+ let ct = binderType b+ in ct { cClock =+ case cClock ct of+ BaseClock -> cl+ KnownClock curCl ->+ KnownClock (renClock curCl)+ ClockVar i ->+ panic "nameCallSite.toBind"+ [ "Unexpected clock variable", showPP i ]+ }+ }+ binds = zipWith toBind ns outs+ let lhs = map LVar ns+ recordCallSite (range ni) lhs+ addFunEqn binds (Define lhs (Call ni es cl (Just $ binderType <$> binds)))+ pure $ case map (Var . Unqual) ns of+ [one] -> one+ notOne -> Tuple notOne+ Nothing -> pure (Call ni es cl mTys)+ where+ isIdent expr =+ case expr of+ ERange _ e -> isIdent e+ Var (Unqual i) -> Just i+ _ -> Nothing++ inB inb =+ case inb of+ InputBinder b -> b+ InputConst i t -> panic "nameCallSite"+ [ "Unexpecetd constant parameter"+ , "*** Name: " ++ showPP i+ , "*** Type: " ++ showPP t ]++++-- | Use a constant to select a branch in a merge.+evalMergeConst :: Env -> Value -> [MergeCase Expression] -> M Expression+evalMergeConst env v ms =+ case ms of+ MergeCase p e : more+ | evalExprToVal env p == v -> evalDynExpr NestedExpr env e+ | otherwise -> evalMergeConst env v more+ [] -> panic "evalMergeConst" [ "None of the branches of a merge matched:"+ , "*** Value: " ++ showPP (valToExpr v)+ ]++-- | Evaluate a case branch of a merge construct.+evalMergeCase :: Env -> MergeCase Expression -> M (MergeCase Expression)+evalMergeCase env (MergeCase p e) =+ MergeCase (evalExpr env p) <$> evalDynExpr NestedExpr env e++-- | Evaluate an update to a struct that is not a constant.+evalUpdExprStruct ::+ Env -> Name -> Expression -> [Field Expression] -> M Expression+evalUpdExprStruct env s e fs =+ do e1 <- evalDynExpr NestedExpr env e+ fs' <- mapM evalField fs+ pure (UpdateStruct (Just s) e1 fs')+ where+ evalField (Field l e1) = Field l <$> evalDynExpr NestedExpr env e1+++-- | Evaluate a dynamic expression declaring a struct literal.+-- Missing fields are added by using the default values declared in the type.+evalNewStruct :: Env -> Name -> [Field Expression] -> M Expression+evalNewStruct env s fs =+ evalNewStructWithDefs env s fs $+ case Map.lookup (nameOrigName s) (C.envStructs (cEnv env)) of+ Just def -> def+ Nothing -> panic "evalNewStruct" [ "Undefined struct type:"+ , "*** Name: " ++ showPP s+ ]+++{- | Evaluate a dynamic expression declaring a struct literal, using+the given list of fields. The list if fields should contain all fields+in the struct, and the 'Maybe' value is an optional default--if it is+'Nothing', then the filed must be defined, otherwise the default is used+in case the filed ismissing. -}+evalNewStructWithDefs ::+ Env -> Name -> [Field Expression] -> [(Label, Maybe Value)] -> M Expression+evalNewStructWithDefs env s fs def =+ do fld <- Map.fromList <$> mapM evalField fs+ pure (Struct s (map (setField fld) def))+ where+ evalField (Field l e) =+ do e1 <- evalDynExpr NestedExpr env e+ return (l,e1)++ setField fld (f,mbV) =+ Field f $+ case Map.lookup f fld of+ Just e -> e+ Nothing ->+ case mbV of+ Just v -> valToExpr v+ Nothing -> panic "evalNewStructWithDefs"+ [ "Missing field in struct:"+ , "*** Name: " ++ showPP f+ ]+++++-- | Generate a new top-level declaration for this node instance.+nameInstance :: Env -> NodeInst -> M NodeInst+nameInstance env (NodeInst fu xs) =+ case xs of+ [] -> pure (NodeInst fu xs)+ _ -> do ys <- mapM (evalStaticArg env) xs+ g <- addNameInstDecl fu ys+ pure (NodeInst (CallUser g) [])++evalStaticArg :: Env -> StaticArg -> M StaticArg+evalStaticArg env sa =+ case sa of+ ArgRange r sa1 -> ArgRange r <$> evalStaticArg env sa1+ NodeArg fu ni -> NodeArg fu <$> nameInstance env ni++ TypeArg t -> pure (TypeArg (evalType env t))+ ExprArg e -> pure (ExprArg (evalExpr env e))+++++--------------------------------------------------------------------------------+-- Expression Evalutaion Monad++type M = WithBase Id [ ReaderT RO+ , StateT RW+ ]++runNameStatic ::+ NameSeed {- ^ Start generating names using this seed -} ->+ Maybe ModName {- ^ What module are we working on at the moment.+ 'Nothing' means use "global" module -} ->+ M a {- ^ This is what we want to do -} ->+ (a, [Binder], [ NodeInstDecl ], Map CallSiteId [LHS Expression], NameSeed)+ -- ^ result, new locals, new instances, call site info, new name seed+runNameStatic seed cm m+ | not (isValidNameSeed seed) =+ panic "runNameStatic"+ [ "Incorrect use of `envNameInstSeed`"+ , "*** Negative seed: " ++ show seed+ ]+ | otherwise = (a, newLocals rw1, reverse (instances rw1)+ , csInfo rw1+ , nameSeed rw1)+ where+ (a,rw1) = runId (runStateT rw (runReaderT cm m))+ rw = RW { nameSeed = seed, instances = [], funEqns = [], newLocals = []+ , csInfo = Map.empty }++type RO = Maybe ModName++data RW = RW+ { nameSeed :: !NameSeed -- ^ Generate new names+ , instances :: [ NodeInstDecl ] -- ^ Generated declarations+ , newLocals :: [ Binder ] -- ^ New locals to declare for 'funEqns'+ , funEqns :: [ Equation ] -- ^ Generated named function call sites+ , csInfo :: Map CallSiteId [LHS Expression]+ -- ^ Identified call sites+ }++recordCallSite :: SourceRange -> [LHS Expression] -> M ()+recordCallSite r xs =+ sets_ $ \s -> s { csInfo = Map.insert (idFromRange r) xs (csInfo s) }+++{- | Name the given instantiation.+XXX: For the moment, all new nodes are "safe nodes".+Eventually, we should probably be more accurate and keep track of the+safety & functionality of declarations.+-}+addNameInstDecl :: Callable -> [StaticArg] -> M Name+addNameInstDecl c as =+ do cm <- ask+ i <- newIdent (range c) cm (Text.pack (show (pp c))) ANode+ addInst NodeInstDecl+ { nodeInstSafety = Safe+ , nodeInstType = Node+ , nodeInstName = origNameToIdent i+ , nodeInstStaticInputs = []+ , nodeInstProfile = Nothing+ , nodeInstDef = NodeInst c as+ }+ pure (origNameToName i)+++++-- | Generate a fresh name associated with the given source location.+newIdent :: SourceRange -> Maybe ModName -> Text -> Thing -> M OrigName+newIdent r md txt th = sets $ \s ->+ let uid = nameSeed s+ lab = Label { labText = txt, labRange = r }+ origI = Ident { identLabel = lab+ , identResolved = Nothing+ }+ origN = OrigName { rnUID = nameSeedToInt uid+ , rnModule = md+ , rnIdent = origI+ , rnThing = th+ }++ s1 = s { nameSeed = nextNameSeed uid }+ in s1 `seq` (origN, s1)+++-- | Remember the given instance.+addInst :: NodeInstDecl -> M ()+addInst ni = sets_ $ \s -> s { instances = ni : instances s }++findInstProf :: Env -> NodeInst -> M (Maybe NodeProfile)+findInstProf env ni@(NodeInst c as) =+ case (c,as) of+ (CallUser n, [])+ | Unqual i <- n -> search (identText i)+ where+ search t = do is <- instances <$> get+ case filter ((t ==) . identText . nodeInstName) is of+ d : _ -> findInstProf env (nodeInstDef d)+ _ -> pure (getNodeInstProfile env ni)++ _ -> pure (getNodeInstProfile env ni)+++-- | Run a computation and collect all named function call sites,+-- returning them. The result of the computation is added last to the list.+collectFunEqns :: M Equation -> M [Equation]+collectFunEqns m =+ do e <- m+ sets $ \s -> (reverse (e : funEqns s), s { funEqns = [] })++-- | Record a new function equation.+addFunEqn :: [Binder] -> Equation -> M ()+addFunEqn bs eqn = sets_ $ \s -> s { newLocals = bs ++ newLocals s+ , funEqns = eqn : funEqns s }
+ Language/Lustre/Transform/NoStruct.hs view
@@ -0,0 +1,985 @@+{-# Language OverloadedStrings, GeneralizedNewtypeDeriving, DataKinds #-}+{- | The purpose of this module is to eliminate structured data.+It should be called after constants have been eliminated, as we then+know the shape of all data. We also assume that function calls have+been named, see "Language.Lustre.Transform.NoStatic". -}+module Language.Lustre.Transform.NoStruct+ ( NosIn(..), NosOut(..)+ , SimpleCallSiteMap, StructInfo, StructData(..)+ , noStruct+ ) where++import Data.Map(Map)+import qualified Data.Map as Map+import qualified Data.Text as Text+import Data.Maybe(fromMaybe)+import Data.List(genericDrop,genericReplicate)+import Data.Traversable(for)+import Text.PrettyPrint((<+>), braces, brackets, parens)+import MonadLib hiding (Label)++import Language.Lustre.Name+import Language.Lustre.AST+import Language.Lustre.Pretty+import Language.Lustre.Transform.NoStatic(CallSiteMap,CallSiteId)+import Language.Lustre.Monad+import Language.Lustre.Utils+import Language.Lustre.Panic++-- | Information needed to perform the no-structure pass.+data NosIn = NosIn+ { nosiStructs :: Map OrigName [(Label,Type)]+ -- ^ Structs from other modules++ , nosiCallSites :: CallSiteMap+ -- ^ Call sites information from the no-static pass+ }++data NosOut = NosOut+ { nosoExpanded :: Map OrigName StructInfo+ -- ^ Specifies how various identifiers got expanded++ , nosoCallSites :: SimpleCallSiteMap+ -- ^ Processed call sites.+ }++runNosM :: NosIn -> NosM a -> LustreM (NosOut, a)+runNosM ni (NosM m) =+ do (a,s) <- runStateT rw $ runReaderT ro m+ let out = NosOut { nosoExpanded = rwCollectedInfo s+ , nosoCallSites = rwSimpleCallSiteMap s+ }+ pure (out, a)+ where+ ro = RO { roStructs = nosiStructs ni+ , roCallSiteTodo = nosiCallSites ni+ }+ rw = RW { rwCollectedInfo = Map.empty+ , rwStructured = Map.empty+ , rwSimpleCallSiteMap = Map.empty+ }++++type SimpleCallSiteMap = Map OrigName (Map CallSiteId [OrigName])++noStruct :: NosIn -> [TopDecl] -> LustreM (NosOut, [TopDecl])+noStruct ni ds = runNosM ni (go [] ds)+ where+ go done todo = case todo of+ [] -> pure (reverse done)+ d : more -> evalTopDecl d $ \mb ->+ case mb of+ Nothing -> go done more+ Just d1 -> go (d1 : done) more+++data StructData a = SLeaf a+ | SArray [StructData a]+ | STuple [StructData a]+ | SStruct OrigName [Field (StructData a)]++instance Functor StructData where+ fmap f st =+ case st of+ SLeaf a -> SLeaf (f a)+ SArray vs -> SArray (fmap (fmap f) vs)+ STuple vs -> STuple (fmap (fmap f) vs)+ SStruct s fs -> SStruct s (fmap (fmap (fmap f)) fs)++instance Foldable StructData where+ foldMap f st =+ case st of+ SLeaf a -> f a+ SArray vs -> foldMap (foldMap f) vs+ STuple vs -> foldMap (foldMap f) vs+ SStruct _ fs -> foldMap (foldMap (foldMap f)) fs++instance Traversable StructData where+ traverse f st =+ case st of+ SLeaf a -> SLeaf <$> f a+ SArray vs -> SArray <$> traverse (traverse f) vs+ STuple vs -> STuple <$> traverse (traverse f) vs+ SStruct x fs -> SStruct x <$> traverse (traverse (traverse f)) fs++++instance Pretty a => Pretty (StructData a) where+ ppPrec n sd =+ case sd of+ SLeaf a -> ppPrec n a+ SArray as -> brackets (commaSep (map pp as))+ STuple as -> parens (commaSep (map pp as))+ SStruct s fs -> pp s <+> braces (commaSep (map pp fs))++-- | Convert a potentially structured expression (already evaluated)+-- into a list of expressions.+flatStructData :: StructData a -> [a]+flatStructData sd =+ case sd of+ SArray es -> concatMap flatStructData es+ STuple es -> concatMap flatStructData es++ -- Here we are assuming that fields are already ordered in some normal form.+ -- Currently, this invariant should be enforced by `NoStatic`, which+ -- places explicit struct fields in the order specified by the struct+ -- declaration.+ SStruct _ fs -> [ v | Field _ e <- fs, v <- flatStructData e ]++ SLeaf a -> [ a ]++++++--------------------------------------------------------------------------------+-- Evaluation of Top Level Declarations++evalTopDecl :: TopDecl -> (Maybe TopDecl -> NosM a) -> NosM a+evalTopDecl td k =+ case td of+ DeclareType tde -> evalTypeDecl tde k++ DeclareConst cd -> panic "evalTopDecl"+ [ "Unexpecetd constant declaration."+ , "*** Declaration: " ++ showPP cd ]++ DeclareNode nd -> do node <- evalNode nd+ k (Just (DeclareNode node))++ DeclareNodeInst nid -> panic "evalTopDecl"+ [ "Node instance declarations should be expanded."+ , "*** Node instance: " ++ showPP nid+ ]++-- | Add a structure definition to the environemnt, or do nothing.+evalTypeDecl :: TypeDecl -> (Maybe TopDecl -> NosM a) -> NosM a+evalTypeDecl td k =+ case typeDef td of+ Just (IsStruct fs) -> doAddStructDef (typeName td) fs (k Nothing)+ _ -> k (Just (DeclareType td))+++-- | Evaluate a node, expanding structured data.+evalNode :: NodeDecl -> NosM NodeDecl+evalNode nd =+ do let prof = nodeProfile nd+ inBs <- expandBinders (map inB (nodeInputs prof))+ outBs <- expandBinders (nodeOutputs prof)+ let newProf = NodeProfile { nodeInputs = map InputBinder inBs+ , nodeOutputs = outBs+ }++ newC <- traverse evalContract (nodeContract nd)++ (simp,newDef) <-+ case nodeDef nd of+ Nothing -> pure (Map.empty, Nothing)+ Just body ->+ do todoCS <- getCSTodo (identOrigName (nodeName nd))+ (simp, body1) <- evalNodeBody todoCS body+ pure (simp, Just body1)++ finishNode (identOrigName (nodeName nd)) simp++ pure nd { nodeProfile = newProf+ , nodeContract = newC+ , nodeDef = newDef }+++inB :: InputBinder -> Binder+inB ib =+ case ib of+ InputBinder b -> b+ InputConst i t -> panic "inB"+ [ "Unexpected input constant:"+ , "*** Name: " ++ showPP i+ , "*** Type: " ++ showPP t ]++-- | Evaluate a node's definition. Expands the local variables,+-- and rewrites the equations.+evalNodeBody ::+ Map a [LHS Expression] ->+ NodeBody ->+ NosM (Map a [OrigName], NodeBody)+evalNodeBody csTodo body =+ do locBs <- expandBinders [ b | LocalVar b <- nodeLocals body ]+ simpCS <- traverse (fmap concat . traverse expandLHS') csTodo+ eqns <- concat <$> traverse evalEqn (nodeEqns body)+ pure ( simpCS+ , NodeBody { nodeLocals = map LocalVar locBs+ , nodeEqns = eqns+ }+ )++++--------------------------------------------------------------------------------+-- Mappings between structured types/data and flat representations.++-- | Compute the list of atomic types in a type.+-- Also returns a boolean to indicate if this was a structured type.+expandType :: Map OrigName [(Label,Type)] -> Type -> (Bool, [([SubName],Type)])+expandType env ty =+ case ty of+ TypeRange r t -> (b, [ (n,TypeRange r u) | (n,u) <- ts ])+ where (b,ts) = expandType env t++ -- Named types are either structs or enums.+ NamedType s | Just fs <- Map.lookup (nameOrigName s) env ->+ ( True, [ (StructEl x : n, t)+ | (x,ts) <- fs+ , (n,t) <- snd (expandType env ts)+ ]+ )++ ArrayType t e ->+ ( True, [ (ArrEl i : n, u)+ | let done = snd (expandType env t)+ , i <- [ 0 .. exprToInteger e - 1 ]+ , (n,u) <- done+ ]+ )++ _ -> (False, [([],ty)])++data SubName = ArrEl Integer | StructEl Label+++-- | Given a type and epxressions for the leaves of a structured value,+-- rebuild the actual value.+-- For example: if @S = { x : int; y : int^3 }@+-- And we are given the leaves: @[e1,e2,e3,e4]@+-- then, the result will be: @{ x = e1, y = [e2,e3,e4] }@+toNormE :: Map OrigName [ (Label, Type) ] -> Type -> [a] -> StructData a+toNormE env t0 es0 =+ case go es0 t0 of+ ([], e) -> e+ _ -> panic "toNormE" [ "Left over expressions after rebuilt" ]+ where+ goMany inEs tys =+ case tys of+ [] -> (inEs , [])+ t : more -> let (rest, outE) = go inEs t+ (rest', outEs) = goMany rest more+ in (rest', outE : outEs)++ go es ty =+ case ty of+ TypeRange _ t -> go es t+ NamedType s | Just fs <- Map.lookup (nameOrigName s) env ->++ let (es', outEs) = goMany es (map snd fs)+ in (es', SStruct (nameOrigName s)+ [ Field l e | ((l,_) ,e) <- zip fs outEs ])++ ArrayType t e ->+ let (es', outEs) = goMany es (genericReplicate (exprToInteger e) t)+ in (es', SArray outEs)++ _ -> case es of+ e : more -> (more, SLeaf e)+ [] -> panic "toNormE" ["Not enogh expressions"]++++--------------------------------------------------------------------------------+++-- | Expand multiple binders. For details, have a look at 'expandBinder'.+expandBinders :: [Binder] -> NosM [Binder]+expandBinders bs = concat <$> traverse expandBinder bs++{- | Expand a binder to a list of binder (non-structured binder are left as is).+For structured binders we also return a mapping from the original name,+to its normal form. For example:++> x : int ^ 3 when t++results in++> x1 : int when t; x2 : int when t; x3 : int when t++and a mapping:++> x = [ x1, x2, x3 ]+-}+expandBinder :: Binder -> NosM [Binder]+expandBinder b =+ do env <- getStructInfo+ case expandType env (cType (binderType b)) of+ (False, _) -> pure [b]+ (True, ts) ->+ do bs <- traverse (newSubName b) ts+ let is = map (identOrigName . binderDefines) bs+ expr = toNormE env (cType (binderType b)) is+ addStructured (identOrigName (binderDefines b)) expr+ pure bs++++++++--------------------------------------------------------------------------------++-- | Expan an equation. If structured data was involved, the result might+-- be multiple equations.+-- Note that the only equations that have multiple binders on the LHS+-- are ones that have a call on the RHS.+evalEqn :: Equation -> NosM [Equation]+evalEqn eqn =+ case eqn of++ Assert x ty e ->+ do e' <- evalExpr e+ pure (case e' of+ SLeaf b -> [ Assert x ty b ]+ _ -> panic "evalEqn" ["Assert expects a bool"])++ Property x e ->+ do e' <- evalExpr e+ pure (case e' of+ SLeaf b -> [ Property x b ]+ _ -> panic "evalEqn" ["PROPERTY expects a bool"])++ IsMain r -> pure [ IsMain r ]++ IVC is -> pure . IVC . concat <$> for is expandIdent+ Realizable is -> pure . Realizable . concat <$> for is expandIdent++ Define lhs e ->+ do es <- flatStructData <$> evalExpr e+ ls <- concat <$> traverse expandLHS lhs+ pure (case es of+ [e1] | isCall e1 -> [ Define ls e1 ]+ _ | otherwise -> zipExact def ls es)++ where+ def l a = Define [l] a+ isCall ex = case ex of+ ERange _ ex1 -> isCall ex1+ Call {} -> True+ _ -> False++ where+ expandIdent :: Ident -> NosM [Ident]+ expandIdent i = do mb <- lkpStrName (Unqual i)+ case mb of+ Nothing -> pure [i]+ Just sd -> pure (map origNameToIdent (flatStructData sd))++expandLHS :: LHS Expression -> NosM [ LHS a ]+expandLHS lhs = map (LVar . origNameToIdent) <$> expandLHS' lhs++-- | Convert a possible complex LHS, to a simple (i.e., identifier) LHS+-- on primitive types.+expandLHS' :: LHS Expression -> NosM [ OrigName ]+expandLHS' lhs = map exprIdLhs . flatStructData <$> evalExpr (lhsToExpr lhs)+ where+ exprIdLhs e =+ case e of+ ERange _ e1 -> exprIdLhs e1+ Var n -> nameOrigName n+ _ -> panic "expandLHS" [ "LHS is not an identifier"+ , "*** Expression: " ++ showPP e ]++-- | Convert a LHS to an expression corresponding to thing being defined.+lhsToExpr :: LHS Expression -> Expression+lhsToExpr lhs =+ case lhs of+ LVar x -> Var (Unqual x)+ LSelect l s -> Select (lhsToExpr l) s++--------------------------------------------------------------------------------+++{- | Move @when@ to the leaves of a structured expressions.+The parameters should be already evaluated.++@[a,b] when c --> [a when c, b when c ]@++Note that clock expressions (e.g., `c` above) are small,+so it is OK to duplicate them. -}++evalWhen :: StructData Expression -> ClockExpr -> StructData Expression+evalWhen ev ce =+ case ev of+ STuple xs -> STuple [ x `evalWhen` ce | x <- xs ]+ SArray xs -> SArray [ x `evalWhen` ce | x <- xs ]+ SStruct s fs -> SStruct s [ Field l (f `evalWhen` ce) | Field l f <- fs ]+ SLeaf e1' -> SLeaf (e1' `When` ce)+++{- | Move a @merege@ to the leaves of structured data.++@ merge c (A -> [1,2]; B -> [3,4]) -->+becomes+[ merge c (A -> 1; B -> 3), merge c (A -> 2; B -> 4) ]+@++Again here we assume that patterns are simple things, as they should be+-}++evalMerge :: Ident -> [MergeCase (StructData Expression)] ->+ StructData Expression+evalMerge i as =+ case as of+ [] -> panic "evalMerge" [ "Empty merge case" ]+ opts@(MergeCase _ o : _) ->+ case getShape o of+ Left _ -> SLeaf (Merge i (map fromLeaf opts))+ where+ fromLeaf a = case a of+ MergeCase p sh ->+ case sh of+ SLeaf e -> MergeCase p e+ _ -> panic "Type error in merge branch"+ [ "Branch: " ++ showPP p+ , "Expected: non-structured"+ , "Got: structured" ]+++ Right sh -> rebuildShape sh mk [ e | MergeCase _ e <- opts ] Nothing+ where+ mk es' _ = evalMerge i+ [ MergeCase p e | (MergeCase p _, e) <- zip opts es' ]+++-- | Lift a binary operator to the leaves of structured data.+-- Assumes that the arguments have the same types, and hence the same shapes.+evalBin :: (Expression -> Expression -> Maybe [CType] -> Expression) ->+ StructData Expression ->+ StructData Expression ->+ Maybe [CType] ->+ StructData Expression+evalBin f e1 e2 mTys =+ case (getShape e1,getShape e2) of+ (Left a, Left b) -> SLeaf (f a b mTys)+ (Right sh1, Right sh2)+ | sh1 == sh2 -> rebuildShape sh1 (\ ~[x,y] tys -> evalBin f x y tys) [e1,e2] mTys+ | otherwise -> panic "Type error in binary operator"+ [ "Shape 1:" ++ showPP sh1+ , "Shape 2:" ++ showPP sh2+ ]+ _ -> panic "Type error in binary operator (structured vs. not)" []+++++-- | Evaluate a struct update+evalStructUpdate ::+ OrigName {- type -} ->+ Expression -> [Field Expression] -> NosM (StructData Expression)+evalStructUpdate s expr es =+ do ev <- evalExpr expr+ case ev of+ SStruct s' oldVal | s == s' ->+ do newVals <- traverse evalField es -- user provided values+ let newMap = Map.fromList [ (l,e) | Field l e <- newVals ]+ pure $ SStruct s+ [ Field l (Map.findWithDefault v l newMap)+ | Field l v <- oldVal ]++ _ -> bad [ "Unexpected value to update:"+ , "*** Expected: a struct"+ , "*** Expression: " ++ showPP ev+ ]+ where+ bad = panic "evalStructUpdate"++-- | Select an item from an array.+selectFromArray ::+ Pretty a => [StructData a] -> Selector Integer -> StructData a+selectFromArray vs s =+ case s of++ SelectField f ->+ panic "selectFromArray"+ [ "Attempt to select a field from an array."+ , "*** Field: " ++ showPP f+ , "*** Array: " ++ showPP (SArray vs)+ ]++ SelectElement i -> getIx i++ SelectSlice sl ->+ let step = fromMaybe 1 (arrayStep sl)+ start = arrayStart sl+ ixes = [ start, start + step .. arrayEnd sl ]+ in SArray (map getIx ixes)++ where+ getIx i = case genericDrop i vs of+ v : _ -> v+ _ -> panic "selectFromArray"+ [ "Selector out of bounds:"+ , "*** Index: " ++ show i+ , "*** Array length: " ++ show (length vs)+ ]++-- | Select an item from a struct.+selectFromStruct :: Pretty a => OrigName -> [Field a] -> Selector Integer -> a+selectFromStruct ty fs s =+ case s of++ SelectField i ->+ case [ v | Field l v <- fs, l == i ] of+ v : _ -> v+ _ -> panic "selectFromStruct"+ [ "Undefined field in selection:"+ , "*** Field: " ++ showPP i+ , "*** Struct: " ++ showPP ty+ , "*** Fields: " ++ show (commaSep (map pp fs))+ ]++ _ -> panic "selectFromStruct"+ [ "Type error in selector."+ , "*** Selector: " ++ showPP s+ , "*** Struct: " ++ showPP ty+ , "*** Fields: " ++ show (commaSep (map pp fs))+ ]++++++-- | Normalize an expression, lifting out structured data to the top.+evalExpr :: Expression -> NosM (StructData Expression)+evalExpr expr =+ case expr of++ ERange _ e -> evalExpr e++ Var x ->+ do mb <- lkpStrName x+ pure (case mb of+ Nothing -> SLeaf expr+ Just y -> Var . origNameToName <$> y)++ Const e t -> liftConst t =<< evalExpr e++ Lit _ -> pure (SLeaf expr)++ -- The clock expression are syntactically restricted to not+ -- contain structured data so we don't need to evaluate them.+ e1 `When` ce ->+ do e1' <- evalExpr e1+ pure (evalWhen e1' ce)++ Tuple es -> STuple <$> traverse evalExpr es+ Array es -> SArray <$> traverse evalExpr es++ Struct s fs -> SStruct (nameOrigName s) <$> traverse evalField fs+ UpdateStruct ~(Just s) e es -> evalStructUpdate (nameOrigName s) e es++ Select e sel ->+ do e1 <- evalExpr e+ let s = evalSelect sel+ pure (case e1 of+ SArray vs -> selectFromArray vs s+ SStruct ty fs -> selectFromStruct ty fs s+ ev -> panic "selectFromStruct"+ [ "Unexpected selection:"+ , "*** StructData: " ++ showPP ev+ ])++ WithThenElse {} -> panic "evalExpr"+ [ "Unexpected with-then-else"+ , "*** Should have been eliminated by 'NoStatic'"+ ]++ Merge i as -> evalMerge i <$> traverse evBranch as+ where evBranch (MergeCase p e) = MergeCase p <$> evalExpr e++ -- XXX: ITERATORS+ Call f es cl mTys ->+ do es' <- traverse evalExpr es++ let bin r op x y tys =+ case cl of+ BaseClock -> eOp2 r op x y tys+ _ -> panic "notClocked"+ [ "Unexpected clock on primitive call." ]+ pure $+ case (f, es') of++ -- [x1,x2] | [y1,y2] ~~> [ x1,x2,y1,y2 ]+ (NodeInst (CallPrim _ (Op2 Concat)) [], [e1,e2]) ->+ SArray (asArray e1 ++ asArray e2)+ where asArray x = case x of+ SArray xs -> xs+ _ -> panic "evalExpr.asArray"+ [ "Not an array:"+ , "*** Expression: " ++ showPP x ]++ -- XXX: This duplicates stuff, perhaps bad+ -- x ^ 2 ~~> [x,x]+ (NodeInst (CallPrim _ (Op2 Replicate)) [], [e1,_]) ->+ SArray (genericReplicate (exprToInteger (es !! 1)) e1)+ -- NOTE: The second argument is a constant.++ -- [x1, x2] fby [y1,y2] ~~~> [ x1 ~~> y1, x2 ~~> y2 ]+ (NodeInst (CallPrim r (Op2 Fby)) [], [e1,e2]) ->+ evalBin (bin r Fby) e1 e2 mTys++ -- [x1, x2] fby [y1,y2] ~~~> [ x1 ~~> y1, x2 ~~> y2 ]+ (NodeInst (CallPrim r (Op2 FbyArr)) [], [e1,e2]) ->+ evalBin (bin r FbyArr) e1 e2 mTys++ -- pre [x,y] ~~~> [pre x, pre y]+ (NodeInst (CallPrim _ (Op1 Pre)) [], args) ->+ case args of+ [e] -> pre <$> e+ _ -> STuple [ pre <$> e | e <- args ]+ where pre a = Call f [a] cl Nothing++ -- current [x,y] -> [current x, current y]+ (NodeInst (CallPrim _ (Op1 Current)) [], args) ->+ case args of+ [e] -> cur <$> e+ _ -> STuple [ cur <$> e | e <- args ]+ where cur a = Call f [a] cl Nothing++ -- currentWith [a,b] [x,y] -> [currentWith a x, currentWith b y]+ (NodeInst (CallPrim r (Op2 CurrentWith)) [], [e1,e2]) ->+ evalBin (bin r CurrentWith) e1 e2 mTys+++ -- if a then [x1,x2] else [y1,y2] ~~>+ -- [ if a then x1 else y1, if a then x2 else y2 ]+ -- XXX: Duplicates `a`+ (NodeInst (CallPrim r ITE) [], [e1,e2,e3]) -> evalBin ite e2 e3 mTys+ where+ ite x y tys =+ case e1 of+ SLeaf b -> Call (NodeInst (CallPrim r ITE) []) [b,x,y] cl tys+ _ -> panic "evalExpr" [ "ITE expects a boolean" ]++ -- [x1, x2] = [y1,y2] ~~~> (x1 = x2) && (y1 = y2)+ (NodeInst (CallPrim r (Op2 Eq)) [], [e1,e2]) ->+ SLeaf $ liftFoldBin (bin r Eq) (bin r And) fTrue e1 e2 mTys++ -- [x1, x2] <> [y1,y2] ~~~> (x1 <> x2) || (y1 <> y2)+ (NodeInst (CallPrim r (Op2 Neq)) [], [e1,e2]) ->+ SLeaf $ liftFoldBin (bin r Neq) (bin r Or) fFalse e1 e2 mTys++ -- f([x1,x2]) ~~~> f(x1,x2)+ (_, evs) -> SLeaf+ $ Call f [ v | e <- evs, v <- flatStructData e ] cl mTys+ where+++ fTrue = Lit (Bool True)+ fFalse = Lit (Bool False)++ liftFoldBin f cons nil e1 e2 mTys =+ -- This just re-uses the same type list that came from the original+ -- Call since this is only used for boolean expressions, in which+ -- case the original type list would have been Just [boolType] and+ -- it's appropriate to use it for all of the subexpressions here.+ fold (\a b -> cons a b mTys)+ nil (zipWith3 f (flatStructData e1) (flatStructData e2) (repeat mTys))++ fold cons nil xs =+ case xs of+ [] -> nil+ _ -> foldr1 cons xs++evalField :: Field Expression -> NosM (Field (StructData Expression))+evalField (Field l e) = Field l <$> evalExpr e+++{- | Lift a type annotation through a structured expression.+Assumes that there are no 'TypeRange' in the types and names refer+directly to their types (see 'checkType' in "Language.Lustre.TypeCheck") -}+liftConst :: CType -> StructData Expression -> NosM (StructData Expression)+liftConst ty str =++ case str of+ SArray es ->+ case cType ty of+ ArrayType t _ -> SArray <$> traverse (liftConst ty { cType = t }) es+ _ -> bad "array"+++ SStruct x fs ->+ case cType ty of+ NamedType y | x == nameOrigName y ->+ do env <- getStructInfo+ case Map.lookup x env of+ -- assumes struct fields are in their declared order+ Just fsTs -> SStruct x <$> zipWithM (liftF x) fsTs fs+ Nothing -> err [ "Undefined structure type: " ++ showPP y ]+ _ -> bad ("struct " ++ showPP x)++ STuple {} -> err ["Type error, unexpected tuple."]++ SLeaf e -> pure (SLeaf (Const e ty))++ where+ liftF x (f,t) fi+ | f == fName fi = traverse (liftConst ty { cType = t }) fi+ | otherwise = err [ "Field order mismatch:"+ , "*** Struct: " ++ showPP x+ , "*** Expected: " ++ showPP f+ , "*** Got: " ++ showPP (fName fi)+ ]++ err = panic "NoStruct.liftConst"++ bad want = err [ "Type mismatch:"+ , "*** Expected: " ++ want+ , "*** Got: " ++ sh+ ]++ sh = case str of+ SArray {} -> "array"+ STuple {} -> "tuple"+ SStruct x _ -> "struct " ++ showPP x+ SLeaf {} -> "leaf"++++++--------------------------------------------------------------------------------++data Shape = ArrayShape Int | StructShape OrigName [Label] | TupleShape Int+ deriving Eq++instance Pretty Shape where+ ppPrec _ sh =+ case sh of+ ArrayShape n -> "array" <+> pp n+ StructShape n fs -> pp n <+> braces (commaSep (map pp fs))+ TupleShape n -> "tuple" <+> pp n+++rebuildShape :: Shape ->+ ([StructData Expression] -> Maybe [CType] -> StructData Expression) ->+ [ StructData Expression ] ->+ Maybe [CType] ->+ StructData Expression+rebuildShape sh mk es mTys =+ let tyList = case mTys of+ -- Turn Nothing into a list of Nothings+ Nothing -> repeat Nothing++ -- Turn Just tys in to Just a list of a singleton type+ Just tys -> (Just . (:[])) <$> tys++ in case sh of++ ArrayShape n -> SArray [ mk (map (getN i) es) tys | i <- take n [ 0 .. ], tys <- tyList ]+ where getN i v = case v of+ SArray vs ->+ case drop i vs of+ el : _ -> el+ [] -> panic "rebuildShape"+ [ "Index out of bounds"+ , "*** Index: " ++ show i ]+ _ -> panic "rebuildShape"+ [ "Shape mismatch"+ , "*** Expected: an array"+ , "*** Got: " ++ showPP v ]+++ TupleShape n -> STuple [ mk (map (getN i) es) tys | i <- take n [ 0 .. ], tys <- tyList ]+ where getN i v = case v of+ STuple vs ->+ case drop i vs of+ el : _ -> el+ [] -> panic "rebuildShape"+ [ "Index out of bounds"+ , "*** Index: " ++ show i ]+ _ -> panic "rebuildShape"+ [ "Shape mismatch"+ , "*** Expected: a tuple"+ , "*** Got: " ++ showPP v ]++ StructShape s is -> SStruct s [ Field i (mk (map (getN i) es) tys)+ | i <- is, tys <- tyList ]+ where getN i v = case v of+ SStruct s' vs | s == s' ->+ case [ fv | Field l fv <- vs, l == i ] of+ el : _ -> el+ [] -> panic "rebuildShape"+ [ "Unknown field"+ , "*** Field: " ++ show i ]+ _ -> panic "rebuildShape"+ [ "Shape mismatch"+ , "*** Expected: a struct"+ , "*** Got: " ++ showPP v ]+++++++-- | Get the outermost shape of an expressio+getShape :: StructData a -> Either a Shape+getShape expr =+ case expr of+ SArray vs -> Right (ArrayShape (length vs))+ SStruct s fs -> Right (StructShape s [ l | Field l _ <- fs ])+ STuple vs -> Right (TupleShape (length vs))+ SLeaf a -> Left a+++-- | Convert a literal expression to integer, or panic.+exprToInteger :: Expression -> Integer+exprToInteger expr =+ case expr of+ ERange _ e -> exprToInteger e+ Lit (Int x) -> x+ _ -> panic "exprToInteger"+ [ "The expression is not an integer constant:"+ , "*** Expression: " ++ showPP expr+ ]++-- | Eval a selector. Since all comstants are expanded, the selectors+-- would be known integers.+evalSelect :: Selector Expression -> Selector Integer+evalSelect sel =+ case sel of+ SelectField i -> SelectField i+ SelectElement e -> SelectElement (exprToInteger e)+ SelectSlice s -> SelectSlice (evalSlice s)++-- | Evaluate a sllice, replacing literal expressions with integers.+evalSlice :: ArraySlice Expression -> ArraySlice Integer+evalSlice s = ArraySlice { arrayStart = exprToInteger (arrayStart s)+ , arrayEnd = exprToInteger (arrayEnd s)+ , arrayStep = exprToInteger <$> arrayStep s+ }+++evalContract :: Contract -> NosM Contract+evalContract c =+ do cis <- mapM evalContractItem (contractItems c)+ pure c { contractItems = cis }++evalContractItem :: ContractItem -> NosM ContractItem+evalContractItem ci =+ case ci of++ Assume l e ->+ do ~(SLeaf e1) <- evalExpr e+ pure (Assume l e1)++ Guarantee l e ->+ do ~(SLeaf e1) <- evalExpr e+ pure (Guarantee l e1)++ _ -> panic "evalContractItem" ["Unsupported contract item."]++++--------------------------------------------------------------------------------++newtype NosM a = NosM { unNosM :: WithBase LustreM+ [ ReaderT RO+ , StateT RW+ ] a }+ deriving (Functor,Applicative,Monad)++data RO = RO+ { roStructs :: !(Map OrigName [(Label,Type)])+ -- ^ Information about struct type defs in scope.++ , roCallSiteTodo :: !CallSiteMap+ -- ^ These call sites need to be simlified;+ -- the result is in "rwSimpleCallSiteMap"+ }++data RW = RW+ { rwCollectedInfo :: !(Map OrigName StructInfo)+ -- ^ Struct info for already processed nodes.++ , rwStructured :: !StructInfo+ -- ^ Structure info for the current node. See "StructInfo"++ , rwSimpleCallSiteMap :: !SimpleCallSiteMap+ -- ^ Call site info for already processed nodes.+ }++{- | Contains the expansions for variables of strucutred types.+For example, if @x : T ^ 3@, then we shoud have a binding+@x = [ x1, x2, x2 ]@.+The expressions in the map should be in evaluated form, which+means that the strucutres data is at the "top" and then we have+variables at the leaves.+-}+type StructInfo = Map OrigName (StructData OrigName)++++-- | Make a new binder, naming a sub-component of the given binder.+newSubName :: Binder -> ([SubName],Type) -> NosM Binder+newSubName b (p,t) = NosM $+ do n <- inBase newInt+ let oldName = binderDefines b+ newText = newSubText (identText oldName) p+ newLab = (identLabel oldName) { labText = newText }+ newName = OrigName+ { rnUID = n+ , rnModule = Nothing+ , rnIdent = oldName { identLabel = newLab+ , identResolved = Nothing }+ , rnThing = AVal+ }++ pure Binder { binderDefines = origNameToIdent newName+ , binderType = (binderType b) { cType = t }+ }+ where+ newSubText u ps = Text.concat (u : map toText ps)+ toText q = case q of+ ArrEl n -> Text.pack ("[" ++ show n ++ "]")+ StructEl f -> "." `Text.append` labText f+++-- | Get information about the struct types that are in scope.+getStructInfo :: NosM (Map OrigName [ (Label,Type)])+getStructInfo = NosM (roStructs <$> ask)++-- | Get what call sites we need to process.+-- These are passed in from the the NoStatic pass.+getCSTodo :: OrigName -> NosM (Map CallSiteId [LHS Expression])+getCSTodo nm =+ do cs <- NosM (roCallSiteTodo <$> ask)+ pure (Map.findWithDefault Map.empty nm cs)++-- | Add information for an expanded local binder.+addStructured :: OrigName -> StructData OrigName -> NosM ()+addStructured x i = NosM $ sets_ $ \s ->+ s { rwStructured = Map.insert x i (rwStructured s) }++-- | Lookup information about a strucutred local.+lkpStrName :: Name -> NosM (Maybe (StructData OrigName))+lkpStrName n = Map.lookup (nameOrigName n) . rwStructured <$> NosM get++++-- | Record information about the expanded binders in a module,+-- and reset the field, so that we can process the next module correctly.+finishNode :: OrigName -> Map CallSiteId [OrigName] -> NosM ()+finishNode nm simp = NosM $ sets_ $ \s ->+ s { rwCollectedInfo = Map.insert nm (rwStructured s) (rwCollectedInfo s)+ , rwStructured = Map.empty+ , rwSimpleCallSiteMap = Map.insert nm simp (rwSimpleCallSiteMap s)+ }++-- | Add a struct definition to the environment.+doAddStructDef :: Ident -> [FieldType] -> NosM a -> NosM a+doAddStructDef i fs m =+ do ro <- NosM ask+ let def = [ (fieldName f, fieldType f) | f <- fs ]+ ro1 = ro { roStructs = Map.insert (identOrigName i) def (roStructs ro)}+ NosM (local ro1 (unNosM m))+++
+ Language/Lustre/Transform/OrderDecls.hs view
@@ -0,0 +1,738 @@+{-# Language DataKinds, GeneralizedNewtypeDeriving, TypeFamilies #-}+{-# Language OverloadedStrings #-}+module Language.Lustre.Transform.OrderDecls+ ( orderTopDecls+ , quickOrderTopDecl+ , ScopeInfo(..)+ , InScope+ ) where++import Data.Text(Text)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set(Set)+import qualified Data.Set as Set+import Data.Maybe(mapMaybe,isJust)+import Data.Graph(SCC(..))+import Data.Graph.SCC(stronglyConnComp)+import Data.Foldable(traverse_)+import MonadLib++import Language.Lustre.Name+import Language.Lustre.AST+import Language.Lustre.Pretty+import Language.Lustre.Monad (LustreM, LustreError(..), ResolverError(..)+ , LustreWarning(..), ResolverWarning(..))+import qualified Language.Lustre.Monad as L+import Language.Lustre.Panic(panic)+import Language.Lustre.Defines+++-- | Resolve some declaration in an empty scope.+-- Useful to quickly test things, or if we are just doing a once off module.+quickOrderTopDecl :: [TopDecl] -> LustreM [TopDecl]+quickOrderTopDecl ds = orderTopDecls scp ds+ where+ scp = ScopeInfo { resInScope = Map.empty+ , resModule = Nothing+ }+++orderTopDecls ::+ ScopeInfo {- ^ Information of what's currently in scope -} ->+ [TopDecl] {- ^ Declarations that need resolving -} ->+ LustreM [TopDecl]++orderTopDecls sci ds = runResolver sci (resolveGroup someRec ds pure)++{- | Order an unordered set of declarations, in dependency order.+The result is a dependency-ordered sequence of strongly-connected+components, and the new names introduced by the declarations -}+resolveGroup ::+ (Defines a, Resolve a) =>+ (SCC a -> ResolveM [a]) -> [a] -> ([a] -> ResolveM b) -> ResolveM b+resolveGroup check ds k =+ do (namess, scope) <- defsOf ds+ extendScope scope $+ do resolved <- zipWithM resolveWithFree namess ds++ let mkRep i ns = [ (n,i) | n <- Set.toList ns ]+ keys = [ 0 .. ] :: [Int]+ repFor = (`Map.lookup` mp)+ where mp = Map.fromList $ concat $ zipWith mkRep keys namess+ mkNode i (a,us) = (a, i, mapMaybe repFor (Set.toList us))+ comps = stronglyConnComp (zipWith mkNode keys resolved)++ k . concat =<< traverse check comps+++-- | Resolve a list of declarations, where the results of each are in scope+-- of the next. The continuation is then executed in the newly computed scope.+-- Note that value identifiers still cannot shadow each other+-- so multiple declarations should still result in errors.+resolveOrderedGroup ::+ (Defines a, Resolve a) => [a] -> ([a] -> ResolveM b) -> ResolveM b+resolveOrderedGroup ds0 k = go [] ds0+ where+ go done todo =+ case todo of+ [] -> k (reverse done)+ d : more ->+ do (~[ds],scope) <- defsOf [d]+ d1 <- resolveDef ds d+ extendScope scope (go (d1 : done) more)++++-- | Check that a given SCC is not recursive.+noRec :: (a -> Ident) {- ^ Pick an identifier to use for the given entry.+ This is used for error reporting. -} ->+ SCC a -> ResolveM [a]+noRec nm x =+ case x of+ AcyclicSCC a -> pure [a]+ CyclicSCC as -> reportError (BadRecursiveDefs (map (identOrigName . nm) as))+++{- | Check that only recursive SCCs are ones that feature only templates+(i.e., node declarations with static parameters).+The idea that this will auto resolve when we specialize the constants. -}+someRec :: SCC TopDecl -> ResolveM [TopDecl]+someRec x =+ case x of+ AcyclicSCC a -> pure [a]+ CyclicSCC cs -> traverse (check cs) cs+ where+ check cs d =+ case d of+ DeclareNode nd | not (null (nodeStaticInputs nd)) -> pure d+ DeclareNodeInst nid | not (null (nodeInstStaticInputs nid)) -> pure d+ _ -> reportError (BadRecursiveDefs (map topDName cs))++ topDName d =+ identOrigName $+ case d of+ DeclareNode nd -> nodeName nd+ DeclareNodeInst nid -> nodeInstName nid+ DeclareType td -> typeName td+ DeclareConst cd -> constName cd+ DeclareContract cd -> cdName cd+++++++--------------------------------------------------------------------------------++class Resolve t where++ -- | Resolve something that may define things.+ -- The first argument specified how to rewrite the defining sites.+ resolveDef :: Set OrigName -> t -> ResolveM t++-- | Resolve something that only uses names, but does not define any.+resolve :: Resolve t => t -> ResolveM t+resolve = resolveDef Set.empty++instance Resolve TopDecl where+ resolveDef ds ts =+ case ts of+ DeclareType td -> DeclareType <$> resolveDef ds td+ DeclareConst cd -> DeclareConst <$> resolveDef ds cd+ DeclareNode nd -> DeclareNode <$> resolveDef ds nd+ DeclareNodeInst nid -> DeclareNodeInst <$> resolveDef ds nid+ DeclareContract cd -> DeclareContract <$> resolveDef ds cd++instance Resolve TypeDecl where+ resolveDef ds t =+ do t1 <- traverse (resolveDef ds) (typeDef t)+ pure TypeDecl { typeName = lkpDef ds AType (typeName t)+ , typeDef = t1 }++instance Resolve TypeDef where+ resolveDef ds td =+ case td of+ IsType t -> IsType <$> resolve t+ IsEnum cs -> pure (IsEnum (map (lkpDef ds AConst) cs))+ IsStruct fs -> IsStruct <$> traverse resolve fs++instance Resolve FieldType where+ resolveDef _ ft = do t1 <- resolve (fieldType ft)+ e1 <- traverse resolveConstExpr (fieldDefault ft)+ pure ft { fieldType = t1, fieldDefault = e1 }++resolveField :: (e -> ResolveM e) -> Field e -> ResolveM (Field e)+resolveField res (Field l e) = Field l <$> res e++instance Resolve Type where+ resolveDef _ ty =+ case ty of+ TypeRange r t -> TypeRange r <$> resolve t++ NamedType t -> NamedType <$> resolveName t AType+ ArrayType t e -> ArrayType <$> resolve t <*> resolveConstExpr e+ IntSubrange e1 e2 -> IntSubrange <$> resolveConstExpr e1+ <*> resolveConstExpr e2++ IntType -> pure ty+ RealType -> pure ty+ BoolType -> pure ty+++instance Resolve ConstDef where+ resolveDef ds cd =+ do t <- traverse resolve (constType cd)+ e <- traverse resolveConstExpr (constDef cd)+ pure ConstDef { constName = lkpDef ds AConst (constName cd)+ , constType = t+ , constDef = e }+++instance Resolve StaticParam where+ resolveDef ds sp =+ case sp of+ TypeParam p -> pure (TypeParam (lkpDef ds AType p))+ ConstParam c t -> ConstParam (lkpDef ds AConst c) <$> resolve t+ NodeParam s f x p ->+ NodeParam s f (lkpDef ds ANode x) <$> resolveProfile p pure+++instance Resolve InputBinder where+ resolveDef ds ib =+ case ib of+ InputBinder b -> InputBinder <$> resolveDef ds b+ InputConst c t -> InputConst (lkpDef ds AConst c) <$> resolve t++instance (Resolve a) => Resolve [a] where+ resolveDef ds vs = mapM resolve vs++instance (Resolve a) => Resolve (Maybe a) where+ resolveDef _ Nothing = pure Nothing+ resolveDef ds (Just v) = Just <$> resolve v++instance Resolve CType where+ resolveDef _ ct =+ do t <- resolve (cType ct)+ c <- resolve (cClock ct)+ pure CType { cType = t, cClock = c }++instance Resolve Binder where+ resolveDef ds b =+ do t <- resolve (binderType b)+ pure Binder { binderDefines = lkpDef ds AVal (binderDefines b)+ , binderType = t+ }+++instance Resolve IClock where+ resolveDef _ cl =+ case cl of+ BaseClock -> pure cl+ KnownClock c -> KnownClock <$> resolve c+ ClockVar i -> panic "Resolve@IClock" [ "Unexpected clock variable"+ , showPP i ]+++instance Resolve StaticArg where+ resolveDef _ sa =+ case sa of+ TypeArg t -> TypeArg <$> resolve t+ ExprArg e -> ExprArg <$> resolveConstExpr e+ NodeArg f ni -> NodeArg f <$> resolve ni+ ArgRange r a -> ArgRange r <$> resolve a+++resolveProfile :: NodeProfile -> (NodeProfile -> ResolveM a) -> ResolveM a+resolveProfile prof k =+ resolveOrderedGroup (nodeInputs prof) $ \ins ->+ resolveOrderedGroup (nodeOutputs prof) $ \outs ->+ k NodeProfile { nodeInputs = ins, nodeOutputs = outs }+++++instance Resolve NodeInstDecl where+ resolveDef ds nid =+ inLocalScope $+ resolveOrderedGroup (nodeInstStaticInputs nid) $ \sinps ->+ let k prof = do def <- resolve (nodeInstDef nid)+ let nm = lkpDef ds ANode (nodeInstName nid)+ pure nid { nodeInstName = nm+ , nodeInstStaticInputs = sinps+ , nodeInstProfile = prof+ , nodeInstDef = def+ }+ in+ case nodeInstProfile nid of+ Nothing -> k Nothing+ Just prof -> resolveProfile prof (k . Just)+++instance Resolve NodeInst where+ resolveDef _ (NodeInst x as) = NodeInst <$> resolve x <*> traverse resolve as++instance Resolve Callable where+ resolveDef _ c =+ case c of+ CallUser n -> CallUser <$> resolveName n ANode+ CallPrim {} -> pure c+++-- XXX: keep track of where we are, so if we report and error we can+-- point to it.+resolveConstExpr :: Expression -> ResolveM Expression+resolveConstExpr expr =+ case expr of+ ERange r e -> ERange r <$> resolveConstExpr e+ Var x -> Var <$> resolveName x AConst+ Lit _ -> pure expr+ When {} -> bad "when"+ Tuple es -> Tuple <$> traverse resolveConstExpr es+ Array es -> Array <$> traverse resolveConstExpr es+ Select e s -> Select <$> resolveConstExpr e <*> resolve s++ Struct x fs ->+ do x1 <- resolveName x AType+ fs1 <- traverse (resolveField resolveConstExpr) fs+ pure (Struct x1 fs1)++ UpdateStruct x e fs ->+ do x1 <- traverse (\a -> resolveName a AType) x+ y1 <- resolveConstExpr e+ fs1 <- traverse (resolveField resolveConstExpr) fs+ pure (UpdateStruct x1 y1 fs1)++ WithThenElse e1 e2 e3 ->+ WithThenElse <$> resolveConstExpr e1+ <*> resolveConstExpr e2 <*> resolveConstExpr e3++ Call ni as c mTys+ | BaseClock <- c ->+ do ni1 <- resolve ni+ as1 <- traverse resolveConstExpr as+ mTys' <- case mTys of+ Nothing -> return Nothing+ Just tys -> Just <$> mapM resolve tys+ pure (Call ni1 as1 BaseClock mTys')+ | otherwise -> bad "call with a clock from a constant"++ Merge {} -> bad "merge"+ Const {} -> panic "resolveConstExpr" [ "Unexpected `Const` expresssion." ]++ where+ bad = reportError . InvalidConstantExpression+++resolveExpr :: Expression -> ResolveM Expression+resolveExpr expr =+ case expr of+ ERange r e -> ERange r <$> resolveExpr e+ Var x -> Var <$> inferName x+ Lit _ -> pure expr+ e1 `When` e2 -> When <$> resolveExpr e1 <*> resolve e2++ Tuple es -> Tuple <$> traverse resolveExpr es+ Array es -> Array <$> traverse resolveExpr es+ Select e s -> Select <$> resolveExpr e <*> resolve s++ Struct x fs ->+ do x1 <- resolveName x AType+ fs1 <- traverse (resolveField resolveExpr) fs+ pure (Struct x1 fs1)++ UpdateStruct x e fs ->+ do x1 <- traverse (`resolveName` AType) x+ e1 <- resolveExpr e+ fs1 <- traverse (resolveField resolveExpr) fs+ pure (UpdateStruct x1 e1 fs1)++ WithThenElse e1 e2 e3 ->+ WithThenElse <$> resolveConstExpr e1+ <*> resolveExpr e2 <*> resolveExpr e3++ Merge x es -> Merge <$> inferIdent x <*> traverse resolve es+ Call f es c ts -> Call <$> resolve f <*> traverse resolveExpr es+ <*> resolve c <*> resolve ts++ Const {} -> panic "resolveConstExpr" [ "Unexpected `Const` expresssion." ]++instance (e ~ Expression) => Resolve (MergeCase e) where+ resolveDef _ (MergeCase c v) =+ MergeCase <$> resolveConstExpr c <*> resolveExpr v++instance Resolve ClockExpr where+ resolveDef _ (WhenClock r cv i) =+ WhenClock r <$> resolveConstExpr cv <*> inferIdent i+++instance Resolve NodeDecl where+ resolveDef ds nd =+ inLocalScope $+ resolveOrderedGroup (nodeStaticInputs nd) $ \sinps ->+ resolveProfile (nodeProfile nd) $ \prof ->+ do ctr <- traverse resolve (nodeContract nd)+ body <- traverse resolve (nodeDef nd)+ pure nd { nodeName = lkpDef ds ANode (nodeName nd)+ , nodeStaticInputs = sinps+ , nodeProfile = prof+ , nodeContract = ctr+ , nodeDef = body+ }++instance Resolve NodeBody where+ resolveDef _ nb =+ -- We do constants before local variables.+ -- This matters if a local variable shadows a global constant.+ -- In that case the, the constant definitions would resolve correctly.+ -- XXX: It is a bit questionable if allowing such definitios is a good idea.+ resolveGroup (noRec getIdent) cs $ \cs1 ->+ resolveGroup (noRec getIdent) vs $ \vs1 ->+ do eqs <- traverse resolve (nodeEqns nb)+ pure NodeBody { nodeLocals = cs1 ++ vs1, nodeEqns = eqs }+ where+ cs = [ LocalConst c | LocalConst c <- nodeLocals nb ]+ vs = [ LocalVar v | LocalVar v <- nodeLocals nb ]+ getIdent x = case x of+ LocalConst c -> constName c+ LocalVar b -> binderDefines b++instance Resolve LocalDecl where+ resolveDef ds ld =+ case ld of+ LocalConst c -> LocalConst <$> resolveDef ds c+ LocalVar v -> LocalVar <$> resolveDef ds v+++instance Resolve Equation where+ resolveDef _ eqn =+ case eqn of+ Assert n t e -> Assert n t <$> resolveExpr e+ Property n e -> Property n <$> resolveExpr e+ Define lhs e -> Define <$> traverse resolve lhs <*> resolveExpr e+ IsMain _ -> pure eqn+ IVC is -> IVC <$> traverse inferIdent is+ Realizable is -> Realizable <$> traverse inferIdent is++instance (e ~ Expression) => Resolve (LHS e) where+ resolveDef _ lhs =+ case lhs of+ LVar i -> LVar <$> resolveIdent i AVal+ LSelect x e -> LSelect <$> resolve x <*> resolve e+++instance (e ~ Expression) => Resolve (Selector e) where+ resolveDef _ sel =+ case sel of+ SelectField _ -> pure sel+ SelectElement e -> SelectElement <$> resolveConstExpr e+ SelectSlice e -> SelectSlice <$> resolve e++instance (e ~ Expression) => Resolve (ArraySlice e) where+ resolveDef _ as =+ do s <- resolveConstExpr (arrayStart as)+ e <- resolveConstExpr (arrayEnd as)+ st <- traverse resolveConstExpr (arrayStep as)+ pure ArraySlice { arrayStart = s, arrayEnd = e, arrayStep = st }++instance Resolve Contract where+ resolveDef _ ct = do is <- resolveContractItems (contractItems ct)+ pure ct { contractItems = is }++resolveContractItems :: [ContractItem] -> ResolveM [ContractItem]+resolveContractItems cits =+ -- The comment on NodeBody also applies here+ resolveGroup (noRec getIdent) cis $ \cs ->+ resolveGroup (noRec getIdent) cvs $ \vs ->+ do others <- traverse resolve (reverse cothers)+ pure (cs ++ vs ++ others)+ where+ (cis,cvs,cothers) = foldr classify ([],[],[]) cits++ classify ci (cs,vs,others) =+ case ci of+ GhostConst {} -> (ci : cs, vs, others)+ GhostVar {} -> (cs, ci : vs, others)+ _ -> (cs, vs, ci : others)++ getIdent ci = case ci of+ GhostConst d -> constName d+ GhostVar b _ -> binderDefines b+ _ -> panic "getIdent (in Contract)"+ [ "Called on non-ghost var/const decl." ]++instance Resolve ContractItem where+ resolveDef ds ci =+ case ci of+ GhostConst d -> GhostConst <$> resolveDef ds d+ GhostVar b e -> GhostVar <$> resolveDef ds b <*> resolveExpr e+ Assume l e -> Assume l <$> resolveExpr e+ Guarantee l e -> Guarantee l <$> resolveExpr e+ -- XXX: resolve mode names+ Mode x mas mgs -> Mode x <$> traverse resolveExpr mas+ <*> traverse resolveExpr mgs+ Import x as bs -> Import <$> resolveIdent x AContract+ <*> traverse resolveExpr as+ <*> traverse resolveExpr bs+++instance Resolve ContractDecl where+ resolveDef ds cd =+ inLocalScope $+ resolveProfile (cdProfile cd) $ \prof ->+ do is <- resolveContractItems (cdItems cd)+ pure cd { cdName = lkpDef ds AContract (cdName cd)+ , cdProfile = prof+ , cdItems = is+ }+++--------------------------------------------------------------------------------++newtype ResolveM a = ResolveM { _unResolveM ::+ WithBase LustreM+ [ ReaderT ScopeInfo+ , StateT ResS+ ] a+ } deriving (Functor,Applicative,Monad)++-- | What's in scope for each module.+type InScope = Map (Maybe ModName) (Map NameSpace (Map Text OrigName))++-- | The "scoped" part of the resolver monad+data ScopeInfo = ScopeInfo+ { resInScope :: InScope -- ^ What's in scope+ , resModule :: Maybe ModName -- ^ Use this for current definitions+ }++-- | The "mutable" part of the resolver monad+newtype ResS = ResS+ { resFree :: Set OrigName -- ^ Free used variables+ }+++runResolver ::+ ScopeInfo ->+ ResolveM a ->+ LustreM a+runResolver r0 (ResolveM m) =+ do let s0 = ResS { resFree = Set.empty }+ (a,_finS) <- runStateT s0 $ runReaderT r0 m+ pure a++++-- | Report the given error, aborting the analysis.+reportError :: L.ResolverError -> ResolveM a+reportError e = ResolveM $ inBase $ L.reportError $ ResolverError e++-- | Record a warning.+addWarning :: L.ResolverWarning -> ResolveM ()+addWarning w = ResolveM $ inBase $ L.addWarning $ ResolverWarning w++-- | Record a use of the given name.+addUse :: OrigName -> ResolveM ()+addUse rn = ResolveM $ sets_ $ \s -> s { resFree = Set.insert rn (resFree s) }+++-- | Compute the definitions from a bunch of things,+-- checking that there are no duplicates.+-- Note that this operation is **effectful**, as it assignes unique+-- identifiers to the defined names.+defsOf :: Defines a => [a] -> ResolveM ([Set OrigName], InScope)+defsOf as =+ do ds <- traverse defsOfOne as+ mp <- traverse check (foldr mergeDefs noDefs ds)+ mo <- ResolveM (resModule <$> ask)+ pure (map defNames ds, Map.singleton mo mp)+ where+ check xs = fmap Map.fromList+ $ mapM isOne+ $ Map.elems+ $ Map.fromListWith (++)+ [ ((rnModule x, origNameTextName x), [x]) | x <- Set.toList xs ]++ isOne xs = case xs of+ [a] -> pure (origNameTextName a, a)+ _ -> reportError (RepeatedDefinitions xs)++ defsOfOne a = ResolveM $+ do l <- resModule <$> ask+ inBase (getDefs a l)++-- | Extend the current scope for the duration of the given computation.+-- The new entries shadow the existing ones.+extendScope :: InScope -> ResolveM a -> ResolveM a+extendScope ds (ResolveM m) =+ do ro <- ResolveM ask+ let new = shadowScope ds (resInScope ro)+ traverse_ (traverse_ (traverse_ reportShadow)) (gotShadowed new)+ a <- ResolveM (local ro { resInScope = newScope new } m)+ -- remove uses of the locally added variables as they are not free+ let isHere x = isJust $ do is <- Map.lookup (rnModule x) ds+ let ns = thingNS (rnThing x)+ Map.lookup ns is+ ResolveM $ sets_+ $ \s -> s { resFree = Set.filter (not . isHere) (resFree s) }+ pure a+++ where+ reportShadow :: OrigName -> ResolveM ()+ reportShadow old =+ case mb of+ Nothing -> panic "extendScope" [ "Shadowed, but not?"+ , "*** Name: " ++ showPP old ]+ Just new ->+ case rnThing old of+ -- value identifiers cannot be shadowed+ AVal -> reportError (RepeatedDefinitions [new, old])+ _ -> addWarning (Shadows new old)++ where+ mb = do ids <- Map.lookup (rnModule old) ds+ nms <- Map.lookup (thingNS (rnThing old)) ids+ Map.lookup (origNameTextName old) nms++++-- | Extend the definitions in the second scope with the first.+-- New entries in the same namespace "shadow" existing ones.+shadowScope :: InScope -> InScope -> WithShadows InScope+shadowScope = joinWith (joinWith joinThings)+ where+ joinWith :: (Ord k, Ord k1) =>+ ShadowFun (Map k v) -> ShadowFun (Map k1 (Map k v))+ joinWith f m1 m2 =+ let mp = Map.mergeWithKey (\_ a b -> Just (f a b)) noShadow noShadow m1 m2+ in WS { newScope = newScope <$> mp+ , gotShadowed = Map.filter (not . Map.null) (gotShadowed <$> mp)+ }++ noShadow m = fmap (\a -> WS { newScope = a, gotShadowed = Map.empty }) m++ joinThings :: ShadowFun (Map Text OrigName)+ joinThings as bs =+ WS { newScope = Map.union as bs+ , gotShadowed = Map.intersectionWith (\_ old -> old) as bs+ }+++{-+ joinThings :: ShadowFun (Map NameSpace (Set OrigName))+ joinThings as bs =+ WS { newScope = Map.unionWith Set.union as bs+ , gotShadowed = Map.intersectionWith (\_ old -> old) as bs+ }+-}+++data WithShadows a = WS { newScope :: a, gotShadowed :: a }+type ShadowFun a = a -> a -> WithShadows a++++-- | Specify the location of names for the scope of the given computation.+withModName :: Maybe ModName -> ResolveM a -> ResolveM a+withModName l (ResolveM m) =+ ResolveM $ mapReader (\ro -> ro { resModule = l }) m++inLocalScope :: ResolveM a -> ResolveM a+inLocalScope = withModName Nothing++-- | Resolve something, and also return its free variables.+-- Note that the free variables are also saved in the state of the monad.+resolveWithFree :: Resolve a => Set OrigName -> a -> ResolveM (a, Set OrigName)+resolveWithFree ds a =+ do free <- ResolveM $ sets $ \s -> (resFree s, s { resFree = Set.empty })+ a1 <- resolveDef ds a+ newFree <- ResolveM $ sets$ \s ->+ let newFree = resFree s+ in (newFree, s { resFree = Set.union newFree free })+ pure (a1, newFree)+++--------------------------------------------------------------------------------+-- Resolving of names++-- | Figure out what a name of the given flavor refers to.+resolveName :: Name -> Thing -> ResolveM Name+resolveName nm th = Unqual <$> newNm+ where+ newNm = case nm of+ Unqual ide -> resolveIdent ide th+ Qual q ide -> resolveIdentIn (Just q) ide th++-- | Figure out what the given name referes to (either value or a constnat).+inferName :: Name -> ResolveM Name+inferName nm = Unqual <$> newNm+ where+ newNm = case nm of+ Unqual ide -> inferIdent ide+ Qual q ide -> inferIdentIn (Just q) ide++resolveIdentIn :: Maybe ModName -> Ident -> Thing -> ResolveM Ident+resolveIdentIn mb i th =+ case identResolved i of+ Nothing ->+ do mbi <- lkpIdent mb th i+ case mbi of+ Nothing -> reportError (UndefinedName (asName mb i))+ Just rn -> do addUse rn+ pure i { identResolved = Just rn }+ Just rn | rnThing rn == th -> pure i+ | otherwise -> panic "resolveIdent"+ [ "Wired-in identifier used in the wrong place"+ , "*** Idnetifier: " ++ show i+ , "*** Expected: " ++ show th+ ]++resolveIdent :: Ident -> Thing -> ResolveM Ident+resolveIdent = resolveIdentIn Nothing++-- | Figure out what the given identifier refers (value or constnat)+inferIdentIn :: Maybe ModName -> Ident -> ResolveM Ident+inferIdentIn mb i =+ do mb1 <- lkpIdent mb AConst i+ mb2 <- lkpIdent mb AVal i+ case (mb1,mb2) of+ (Nothing, Nothing) -> reportError (UndefinedName (asName mb i))+ (Just p, Just q)+ | p /= q -> reportError (AmbiguousName (asName mb i) p q)+ | otherwise -> do addUse p+ pure i { identResolved = Just p }+ (Just rn,Nothing) -> do addUse rn+ pure i { identResolved = Just rn }+ (Nothing, Just rn) -> do addUse rn+ pure i { identResolved = Just rn }++asName :: Maybe ModName -> Ident -> Name+asName mb i = case mb of+ Nothing -> Unqual i+ Just m -> Qual m i++inferIdent :: Ident -> ResolveM Ident+inferIdent = inferIdentIn Nothing+++-- | Lookup something in the current scope.+lkpIdent :: Maybe ModName -> Thing -> Ident -> ResolveM (Maybe OrigName)+lkpIdent loc th i =+ do scope <- ResolveM (resInScope <$> ask)+ pure $ do defs <- Map.lookup loc scope+ nms <- Map.lookup (thingNS th) defs+ Map.lookup (identText i) nms++-- | Resolve a name in a defining position.+lkpDef :: Set OrigName -> Thing -> Ident -> Ident+lkpDef ds th i = case Set.minView (Set.filter matches ds) of+ Just (a,_) -> i { identResolved = Just a }+ _ -> panic "lkpDef" [ "Missing identifier for defining site"+ , "*** Identifier: " ++ showPP i+ , "*** Context: " ++ showPP th+ ]+ where+ matches j = rnThing j == th && identText (rnIdent j) == identText i+++
+ Language/Lustre/Transform/ToCore.hs view
@@ -0,0 +1,606 @@+{-# Language FlexibleInstances #-}+{-# Language OverloadedStrings #-}+{-# Language TypeSynonymInstances #-}+-- | Translate siplified Lustre into the Core representation.+module Language.Lustre.Transform.ToCore+ ( getEnumInfo, EnumInfo, evalNodeDecl, enumFromVal+ ) where++import Data.Map(Map)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Semigroup ( (<>) )+import Data.Text (Text)+import qualified Data.Text as Text+import MonadLib hiding (Label)+import AlexTools(SourceRange(..),SourcePos(..))+import Data.Foldable(toList)+import Data.Graph.SCC(stronglyConnComp)++import Language.Lustre.Name+import qualified Language.Lustre.AST as P+import qualified Language.Lustre.Core as C+import Language.Lustre.Core (CoreName, coreNameFromOrig)+import Language.Lustre.Monad+import Language.Lustre.Panic+import Language.Lustre.Pretty(showPP)+++data EnumInfo = EnumInfo+ { enumConMap :: !(Map OrigName C.Literal)+ -- ^ Maps enum constructor to value++ , enumMax :: !(Map OrigName C.Literal)+ -- ^ Maps enum type to largest con++ , enumFromVal :: !(Map (OrigName,Integer) OrigName)+ -- ^ Given a type and a number, give back the constructor.+ }++blankEnumInfo :: EnumInfo+blankEnumInfo = EnumInfo { enumConMap = Map.empty+ , enumMax = Map.empty+ , enumFromVal = Map.empty+ }++-- | Compute info about enums from some top-level declarations.+-- The result maps the original names of enum constructors, to numeric+-- expressions that should represent them.+getEnumInfo :: [ P.TopDecl ] {- ^ Renamed decls -} -> EnumInfo+getEnumInfo tds = foldr addDefs blankEnumInfo enums+ where+ aliases = Map.fromList+ [ (nameOrigName t, identOrigName n) | P.DeclareType+ P.TypeDecl { P.typeName = n+ , P.typeDef = Just (P.IsType (P.NamedType t))+ } <- tds+ ]++ enumAliases n = case Map.lookup n aliases of+ Nothing -> [n]+ Just s -> s : enumAliases s+++ enums = [ (identOrigName n,is) | P.DeclareType+ P.TypeDecl { P.typeName = n+ , P.typeDef = Just (P.IsEnum is) } <- tds ]++ -- The constructors of an enum are represented by 0, 1, .. etc+ addDefs (n,is) ei = EnumInfo+ { enumConMap = foldr addDef (enumConMap ei) (zipWith mkDef is [ 0 .. ])+ , enumMax = Map.insert n (C.Int (fromIntegral (length is) - 1))+ (enumMax ei)+ , enumFromVal = Map.union+ (Map.fromList (concatMap (mkRevDef n) (zip [0..] is)))+ (enumFromVal ei)++ }+++ mkDef i n = (identOrigName i, C.Int n)+ mkRevDef n (i,c) = [ ((j,i),identOrigName c) | j <- enumAliases n ]++ addDef (i,n) = Map.insert i n+++-- | Translate a node to core form, given information about enumerations.+-- We don't return a mapping from original name to core names because+-- for the moment this mapping is very simple: just use 'origNameToCoreName'+evalNodeDecl ::+ EnumInfo {- ^ Information about enums -} ->+ P.NodeDecl {- ^ Simplified source Lustre -} ->+ LustreM C.Node+evalNodeDecl enumCs nd+ | null (P.nodeStaticInputs nd)+ , Just def <- P.nodeDef nd =+ runProcessNode enumCs $+ do let prof = P.nodeProfile nd+ ins <- mapM evalInputBinder (P.nodeInputs prof)+ outs <- mapM evalBinder (P.nodeOutputs prof)+ locs <- mapM evalBinder+ $ orderLocals [ b | P.LocalVar b <- P.nodeLocals def ]++ eqnss <- mapM evalEqn (P.nodeEqns def)+ let withDef = Set.fromList+ [ x | eqns <- eqnss, (x C.::: _) C.:= _ <- eqns ]++ asts <- getAssertNames+ props <- getPropertyNames+ pure C.Node { C.nName = P.nodeName nd+ , C.nInputs = ins+ , C.nOutputs = outs+ , C.nAbstract = [ l | l@(x C.::: _) <- locs+ , not (x `Set.member` withDef) ]+ , C.nAssuming = asts+ , C.nShows = props+ , C.nEqns = C.orderedEqns (concat eqnss)+ }++ | otherwise = panic "evalNodeDecl"+ [ "Unexpected node declaration"+ , "*** Node: " ++ showPP nd+ ]++ where+ depsOf b = case P.cClock (P.binderType b) of+ P.KnownClock (P.WhenClock _ _ c) -> [c]+ _ -> []++ orderLocals bs = concatMap toList+ $ stronglyConnComp [ (b,P.binderDefines b,depsOf b) | b <- bs]+++-- | Rewrite a type, replacing named enumeration types with @int@.+evalType :: P.Type -> C.Type+evalType ty =+ case ty of+ P.NamedType {} -> C.TInt -- Only enum types should be left by now+ P.IntSubrange {} -> C.TInt -- Represented with a number+ P.IntType -> C.TInt+ P.RealType -> C.TReal+ P.BoolType -> C.TBool+ P.TypeRange _ t -> evalType t+ P.ArrayType {} -> panic "evalType"+ [ "Unexpected array type"+ , "*** Type: " ++ showPP ty+ ]++--------------------------------------------------------------------------------+type M = StateT St LustreM+++runProcessNode :: EnumInfo -> M a -> LustreM a+runProcessNode enumCs m =+ do (a,_finS) <- runStateT st m+ pure a+ where+ st = St { stLocalTypes = Map.empty+ , stSrcLocalTypes = Map.empty+ , stGlobEnumCons = enumCs+ , stEqns = []+ , stAssertNames = []+ , stPropertyNames = []+ , stVarMap = Map.empty+ }++data St = St+ { stLocalTypes :: Map CoreName C.CType+ -- ^ Types of local translated variables.+ -- These may change as we generate new equations.++ , stSrcLocalTypes :: Map OrigName C.CType+ -- ^ Types of local variables from the source.+ -- These shouldn't change.++ , stGlobEnumCons :: EnumInfo+ -- ^ Definitions for enum constants.+ -- Currently we assume that these would be int constants.++ , stEqns :: [C.Eqn]+ -- ^ Generated equations naming subcomponents.+ -- Most recently generated first.+ -- Since we process things in depth-first fashion, this should be+ -- reverse to get proper definition order.++ , stAssertNames :: [(Label,CoreName)]+ -- ^ The names of the equations corresponding to asserts.++ , stPropertyNames :: [(Label,CoreName)]+ -- ^ The names of the equatiosn corresponding to properties.+++ , stVarMap :: Map OrigName CoreName+ {- ^ Remembers what names we used for values in the core.+ This is so that when we can parse traces into their original names. -}+ }++-- | Get the collected assert names.+getAssertNames :: M [(Label,CoreName)]+getAssertNames = stAssertNames <$> get++-- | Get the collected property names.+getPropertyNames :: M [(Label,CoreName)]+getPropertyNames = stPropertyNames <$> get++-- | Get the map of enumeration constants.+getEnumCons :: M EnumInfo+getEnumCons = stGlobEnumCons <$> get++-- | Get the collection of local types.+getLocalTypes :: M (Map CoreName C.CType)+getLocalTypes = stLocalTypes <$> get++-- | Record the type of a local.+addLocal :: CoreName -> C.CType -> M ()+addLocal i t = sets_ $ \s -> s { stLocalTypes = Map.insert i t (stLocalTypes s)}++addBinder :: C.Binder -> M ()+addBinder (i C.::: t) = addLocal i t++-- | Generate a fresh local name with the given stemp+newIdentFrom :: Text -> M CoreName+newIdentFrom stem =+ do x <- inBase newInt+ let i = Ident { identLabel = toLabel stem+ , identResolved = Nothing+ }+ o = OrigName { rnUID = x+ , rnModule = Nothing+ , rnIdent = i+ , rnThing = AVal+ }+ pure (coreNameFromOrig o)+++toLabel :: Text -> Label+toLabel t = Label { labText = t, labRange = noLoc }++-- XXX: Currently core epxressions have no locations.+noLoc :: SourceRange+noLoc = SourceRange { sourceFrom = noPos, sourceTo = noPos }+ where+ noPos = SourcePos { sourceIndex = -1, sourceLine = -1+ , sourceColumn = -1, sourceFile = "" }+++-- | Remember an equation.+addEqn :: C.Eqn -> M ()+addEqn eqn@(i C.::: t C.:= _) =+ do sets_ $ \s -> s { stEqns = eqn : stEqns s }+ addLocal i t++-- | Return the collected equations, and clear them.+clearEqns :: M [ C.Eqn ]+clearEqns = sets $ \s -> (stEqns s, s { stEqns = [] })++-- | Generate a fresh name for this expression, record the equation,+-- and return the name.+nameExpr :: C.Expr -> M C.Atom+nameExpr expr =+ do tys <- getLocalTypes+ let t = C.typeOf tys expr+ i <- newIdentFrom stem+ addEqn (i C.::: t C.:= expr)+ pure (C.Var i)++ where+ stem = case expr of+ C.Atom a -> case a of+ C.Prim op _ _ -> Text.pack (show op)+ _ -> panic "nameExpr" [ "Naming a simple atom?"+ , "*** Atom:" ++ showPP a ]+ C.Pre a -> namedStem "pre" a+ _ C.:-> a -> namedStem "init" a+ C.When _ a -> namedStem "when" a+ C.Current a -> namedStem "current" a+ C.Merge (a, _) _ -> namedStem "merge" (C.Var a)++ namedStem t a = case a of+ C.Var i -> t <> "_" <> C.coreNameTextName i+ _ -> "$" <> t++-- | Remember that the given identifier was used for an assert.+addAssertName :: Label -> CoreName -> M ()+addAssertName t i = sets_ $ \s -> s { stAssertNames = (t,i) : stAssertNames s }++-- | Remember that the given identifier was used for a property.+addPropertyName :: Label -> CoreName -> M ()+addPropertyName t i =+ sets_ $ \s -> s { stPropertyNames = (t,i) : stPropertyNames s }+++--------------------------------------------------------------------------------++evalInputBinder :: P.InputBinder -> M C.Binder+evalInputBinder inp =+ case inp of+ P.InputBinder b -> do b1 <- evalBinder b+ inputTypeAsmps b1 (P.cType (P.binderType b))+ pure b1+ P.InputConst i t ->+ panic "evalInputBinder"+ [ "Unexpected constant parameter"+ , "*** Name: " ++ showPP i+ , "*** Type: " ++ showPP t ]+++-- | Type assumptions for an input.+-- Currently these are assumptions arising from sub-range types and enums.+inputTypeAsmps :: C.Binder -> P.Type -> M ()+inputTypeAsmps (v C.::: ct) ty =++ case ty of+ P.NamedType i ->+ do x <- getEnumCons+ case Map.lookup (nameOrigName i) (enumMax x) of+ Just s -> inRange (C.Int 0) s+ Nothing -> panic "inputTypeAsmps"+ [ "Undefined `enum` type", showPP i ]++ P.IntSubrange l u ->+ do le <- evalConstExpr l+ ue <- evalConstExpr u+ inRange le ue++ P.IntType -> pure ()+ P.RealType -> pure ()+ P.BoolType -> pure ()+ P.TypeRange {} -> panic "evalTypeAsmps" [ "Unexpected type range" ]+ P.ArrayType {} -> panic "evalTypeAsmps"+ [ "Unexpected array type"+ , "*** Type: " ++ showPP ty+ ]+++ where+ lit l = C.Lit l ct++ inRange x y =+ do let va = C.Var v+ lb = C.Prim C.Leq [ lit x, va ] [boolTy]+ ub = C.Prim C.Leq [ va, lit y ] [boolTy]+ prop = C.Prim C.And [ lb, ub ] [boolTy]+ boolTy = C.TBool `C.On` C.clockOfCType ct+ lab = C.coreNameTextName v <> "_bounds"+ pn <- newIdentFrom lab+ let lhs = pn C.::: C.TBool `C.On` C.clockOfCType ct+ eqn = lhs C.:= C.Atom prop+ addEqn eqn+ addAssertName (toLabel lab) pn+++-- | Add the type of a binder to the environment.+evalBinder :: P.Binder -> M C.Binder+evalBinder b =+ do c <- case P.cClock (P.binderType b) of+ P.BaseClock -> pure C.BaseClock+ P.KnownClock c -> C.WhenTrue <$> evalClockExpr c+ P.ClockVar i -> panic "evalBinder"+ [ "Unexpected clock variable", showPP i ]+ let t = evalType (P.cType (P.binderType b)) `C.On` c+ let xi = evalIdent (P.binderDefines b)+ addLocal xi t+ let bn = xi C.::: t+ addBinder bn+ pure bn++-- | Translate an equation.+-- Invariant: 'stEqns' should be empty before and after this executes.+evalEqn :: P.Equation -> M [C.Eqn]+evalEqn eqn =+ case eqn of+ P.IsMain _ -> pure []+ P.IVC _ -> pure [] -- XXX: we should do something with these+ P.Realizable _ -> pure [] -- XXX: we should do something with these++ P.Property t e -> evalForm "--%PROPERTY" (addPropertyName t) e+ P.Assert t _ty e -> evalForm "assert" (addAssertName t) e+ -- at the top-level both kinds of assert are treated as assumptions.++ P.Define ls e ->+ case ls of+ [ P.LVar x ] ->+ do tys <- getLocalTypes+ let x' = evalIdent x+ let t = case Map.lookup x' tys of+ Just ty -> ty+ Nothing ->+ panic "evalEqn" [ "Defining unknown variable:"+ , "*** Name: " ++ showPP x ]+ e1 <- evalExpr (Just x') e+ addEqn (x' C.::: t C.:= e1)+ clearEqns+++ _ -> panic "evalExpr"+ [ "Unexpected LHS of equation"+ , "*** Equation: " ++ showPP eqn+ ]++ where+ evalForm :: String -> (CoreName -> M ()) -> P.Expression -> M [ C.Eqn ]+ evalForm x f e =+ do e1 <- evalExprAtom e+ case e1 of+ C.Var i ->+ do f i+ clearEqns+ C.Lit n _ ->+ case n of+ C.Bool True -> pure []+ _ -> panic ("Constant in " ++ x) [ "*** Constant: " ++ show n ]+ C.Prim {} ->+ do ~(C.Var i) <- nameExpr (C.Atom e1)+ f i+ clearEqns++++-- | Evaluate a source expression to an a core atom, naming subexpressions+-- as needed.+evalExprAtom :: P.Expression -> M C.Atom+evalExprAtom expr =+ do e1 <- evalExpr Nothing expr+ case e1 of+ C.Atom a -> pure a+ _ -> nameExpr e1+++evalIdent :: Ident -> CoreName+evalIdent = coreNameFromOrig . identOrigName++++-- | Evaluate a clock-expression to an atom.+evalClockExpr :: P.ClockExpr -> M C.Atom+evalClockExpr (P.WhenClock _ e1 i) =+ do a1 <- evalConstExpr e1+ env <- getLocalTypes+ let a2 = C.Var (evalIdent i)+ ty = C.typeOf env a2+ boolTy = C.TBool `C.On` C.clockOfCType ty+ pure $ case a1 of+ C.Bool True -> a2+ _ -> C.Prim C.Eq [ C.Lit a1 ty, a2 ] [boolTy]++evalIClock :: P.IClock -> M C.Clock+evalIClock clo =+ case clo of+ P.BaseClock -> pure C.BaseClock+ P.KnownClock c -> C.WhenTrue <$> evalClockExpr c+ P.ClockVar {} -> panic "evalIClockExpr" [ "Unexpectec clock variable." ]++evalCurrentWith :: Maybe CoreName -> C.Atom -> C.Atom -> M C.Expr+evalCurrentWith xt d e =+ do env <- getLocalTypes+ let ty = C.typeOf env e+ c@(C.WhenTrue ca) = C.clockOfCType ty+ Just cc = C.clockParent env c+ case xt of+ Just x -> desugar x ca ty+ Nothing ->+ do i <- newIdentFrom "curW"+ let thisTy = C.typeOfCType ty `C.On` cc+ addLocal i thisTy+ e1 <- desugar i ca thisTy+ addEqn (i C.::: thisTy C.:= e1)+ pure (C.Atom (C.Var i))+ where+ desugar x c ty =+ do cur <- nameExpr (C.Current e)+ pre <- nameExpr (C.Pre (C.Var x))+ hold <- nameExpr ((d, ty) C.:-> pre)+ pure (C.Atom (C.Prim C.ITE [c,cur,hold] [ty]))++evalConstExpr :: P.Expression -> M C.Literal+evalConstExpr expr =+ case expr of+ P.ERange _ e -> evalConstExpr e+ P.Var i ->+ do cons <- getEnumCons+ case Map.lookup (nameOrigName i) (enumConMap cons) of+ Just e -> pure e+ Nothing -> bad "undefined constant symbol"+ P.Lit l -> pure l+ _ -> bad "constant expression"++ where+ bad msg = panic "evalConstExpr" [ "Unexpected " ++ msg+ , "*** Expression: " ++ showPP expr+ ]++evalCType :: P.CType -> M C.CType+evalCType t =+ do c <- evalIClock (P.cClock t)+ pure (evalType (P.cType t) `C.On` c)++-- | Evaluate a source expression to a core expression.+evalExpr :: Maybe CoreName -> P.Expression -> M C.Expr+evalExpr xt expr =+ case expr of+ P.ERange _ e -> evalExpr xt e++ P.Var i -> pure (C.Atom (C.Var (coreNameFromOrig (nameOrigName i))))++ P.Const e t ->+ do l <- evalConstExpr e+ ty <- evalCType t+ pure (C.Atom (C.Lit l ty))++ P.Lit {} -> bad "literal outside `Const`."++ e `P.When` ce ->+ do a1 <- evalExprAtom e+ a2 <- evalClockExpr ce+ pure (C.When a1 a2)+++ P.Merge i alts ->+ do let iName = evalIdent i+ env <- getLocalTypes+ let ty = C.typeOf env (C.Var iName)++ bs <- forM alts $ \(P.MergeCase k e) -> do p <- evalConstExpr k+ e' <- evalExprAtom e+ pure (p,e')++ pure (C.Merge (iName, ty) bs)++ P.Tuple {} -> bad "tuple"+ P.Array {} -> bad "array"+ P.Select {} -> bad "selection"+ P.Struct {} -> bad "struct"+ P.UpdateStruct {} -> bad "update-struct"+ P.WithThenElse {} -> bad "with-then-else"++ P.Call ni es _ Nothing ->+ panic "ToCore.evalExpr" $ [ "Got a Call with no type", "NodeInst:", show ni, "Arguments:"] ++ (show <$> es)++ P.Call ni es cl (Just tys) ->+ do _clv <- evalIClock cl+ tys' <- mapM evalCType tys+ {- NOTE: we don't really store the clock of the call anywhere,+ because for primitives (which is all that should be left)+ it can be computed from the clocks of the arguments. -}++ as <- mapM evalExprAtom es+ let prim x = pure (C.Atom (C.Prim x as tys'))+ case ni of+ P.NodeInst (P.CallPrim _ p) [] ->+ case p of++ P.Op1 op1 ->+ case as of+ [v] -> case op1 of+ P.Not -> prim C.Not+ P.Neg -> prim C.Neg+ P.Pre -> pure (C.Pre v)+ P.Current -> pure (C.Current v)+ P.IntCast -> prim C.IntCast+ P.FloorCast-> prim C.FloorCast+ P.RealCast -> prim C.RealCast+ _ -> bad "unary operator"++ P.Op2 op2 ->+ case as of+ [v1,v2] -> case op2 of+ P.Fby -> do v3 <- nameExpr (C.Pre v2)+ pure ((v1, tys' !! 0) C.:-> v3)+ P.FbyArr -> pure ((v1, tys' !! 0) C.:-> v2)+ P.CurrentWith -> evalCurrentWith xt v1 v2+ P.And -> prim C.And+ P.Or -> prim C.Or+ P.Xor -> prim C.Xor+ P.Implies -> prim C.Implies+ P.Eq -> prim C.Eq+ P.Neq -> prim C.Neq+ P.Lt -> prim C.Lt+ P.Leq -> prim C.Leq+ P.Gt -> prim C.Gt+ P.Geq -> prim C.Geq+ P.Mul -> prim C.Mul+ P.Mod -> prim C.Mod+ P.Div -> prim C.Div+ P.Add -> prim C.Add+ P.Sub -> prim C.Sub+ P.Power -> prim C.Power+ P.Replicate -> bad "`^`"+ P.Concat -> bad "`|`"+ _ -> bad "binary operator"++ P.OpN op ->+ case op of+ P.AtMostOne -> prim C.AtMostOne+ P.Nor -> prim C.Nor+++ P.ITE -> prim C.ITE++ _ -> bad "primitive call"++ _ -> bad "function call"++ where+ bad msg = panic "ToCore.evalExpr" [ "Unexpected " ++ msg+ , "*** Expression: " ++ showPP expr+ ]
+ Language/Lustre/TypeCheck.hs view
@@ -0,0 +1,1090 @@+{-# Language OverloadedStrings, Rank2Types #-}+module Language.Lustre.TypeCheck where++import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.List (find,transpose)+import Control.Monad(unless,zipWithM_,zipWithM,foldM)+import Text.PrettyPrint as PP+import Data.List(group,sort)+import Data.Traversable(for)+import Data.Foldable(for_)++import Language.Lustre.Name+import Language.Lustre.AST+import Language.Lustre.Pretty+import Language.Lustre.Panic+import Language.Lustre.Monad(LustreM)+import Language.Lustre.TypeCheck.Monad+import Language.Lustre.TypeCheck.Constraint+import Language.Lustre.TypeCheck.Prims+import Language.Lustre.TypeCheck.Utils+++type TypeError = Doc+type TypeWarn = Doc+++-- | Assumes that the declarations are in dependency order.+quickCheckDecls :: [TopDecl] -> LustreM [TopDecl]+quickCheckDecls ds = runTC (go ds)+ where+ go xs = case xs of+ [] -> pure []+ x : more -> do (y,ys) <- checkTopDecl x (go more)+ pure (y:ys)+++checkTopDecl :: TopDecl -> M a -> M (TopDecl,a)+checkTopDecl td m =+ case td of+ DeclareType tyd -> apFstM DeclareType (checkTypeDecl tyd m)+ DeclareConst cd -> apFstM DeclareConst (checkConstDef cd m)+ DeclareNode nd -> apFstM DeclareNode (checkNodeDecl nd m)+ DeclareNodeInst _nid -> notYetImplemented "node instances"+ DeclareContract {} -> notYetImplemented "top-level contract"+++checkTypeDecl :: TypeDecl -> M a -> M (TypeDecl, a)+checkTypeDecl td m =+ case typeDef td of+ Nothing -> addFst td $ withNamedType (typeName td) AbstractTy m+ Just dec ->+ case dec of++ IsEnum is ->+ do let nty = NamedType (Unqual ti)+ addE i = withConst i nty+ ty = EnumTy (Set.fromList (map identOrigName is))+ addFst td (withNamedType ti ty (foldr addE m is))++ IsStruct fs ->+ do fs1 <- mapM checkFieldType fs+ mapM_ checkDup $ group $ sort $ map fieldName fs1+ let ty = StructTy fs1+ newTD = td { typeDef = Just (IsStruct fs1) }+ addFst newTD (withNamedType ti ty m)++ IsType t ->+ do t' <- checkType t+ let newTD = td { typeDef = Just (IsType t') }+ addFst newTD (withNamedType ti (AliasTy t') m)+ where+ ti = typeName td++ checkDup xs =+ case xs of+ [] -> pure ()+ [_] -> pure ()+ x : _ ->+ reportError $ nestedError+ "Multiple fields with the same name." $+ [ "Struct:" <+> pp (typeName td)+ , "Field:" <+> pp x+ ] ++ [ "Location:" <+> pp (range f) | f <- xs ]+++checkFieldType :: FieldType -> M FieldType+checkFieldType f =+ do let t = fieldType f+ t1 <- checkType t+ d1 <- case fieldDefault f of+ Nothing -> pure Nothing+ Just e -> do e' <- checkConstExpr e t+ pure (Just e')+ pure f { fieldType = t1, fieldDefault = d1 }++checkNodeDecl :: NodeDecl -> M a -> M (NodeDecl,a)+checkNodeDecl nd k =+ do newNd <- check+ addFst newNd+ $ withNode NodeInfo+ { niName = nodeName newNd+ , niSafety = nodeSafety newNd+ , niType = nodeType newNd+ , niStaticParams = nodeStaticInputs newNd+ , niProfile = nodeProfile newNd+ }+ k+ where+ check :: M NodeDecl+ check =+ inRange (range (nodeName nd)) $+ inClockScope $+ allowTemporal (nodeType nd == Node) $+ allowUnsafe (nodeSafety nd == Unsafe) $+ do (ps,(prof,ctr,bod)) <-+ checkStaticParams (nodeStaticInputs nd) $+ do {-when (nodeExtern nd) $+ case nodeDef nd of+ Just _ -> reportError $ nestedError+ "Extern node with a definition."+ ["Node:" <+> pp (nodeName nd)]+ Nothing -> pure ()-}+ let prof = nodeProfile nd+ (ins,(outs,(ctr,bod))) <-+ checkInputBinders (nodeInputs prof) $+ checkOutputBinders (nodeOutputs prof) $+ do c <- traverse checkContract (nodeContract nd)+ -- XXX: maybe check that outputs are not mentioned in assume?++ b <- case nodeDef nd of+ Nothing ->+ do unless (nodeExtern nd)+ $ reportError $ nestedError+ "Missing node definition"+ ["Node:" <+> pp (nodeName nd)]+ pure Nothing+ Just b -> Just <$> checkNodeBody b+ pure (c,b)++ let newProf = NodeProfile { nodeInputs = ins+ , nodeOutputs = outs+ }++ ctr1 <- traverse zonkContract ctr+ bod1 <- traverse zonkBody bod++ pure (newProf, ctr1, bod1)++ pure nd { nodeStaticInputs = ps+ , nodeProfile = prof+ , nodeContract = ctr+ , nodeDef = bod }++checkStaticParam :: StaticParam -> M a -> M (StaticParam,a)+checkStaticParam sp m =+ case sp of+ TypeParam t ->+ do a <- withNamedType t AbstractTy m+ pure (TypeParam t, a)++ ConstParam x t ->+ do t1 <- checkType t+ a <- withConst x t1 m+ pure (ConstParam x t1, a)++ NodeParam safe fun f prof ->+ do (is,(os,_)) <- checkInputBinders (nodeInputs prof) $+ checkOutputBinders (nodeOutputs prof) $+ pure ()+ let prof1 = NodeProfile { nodeInputs = is, nodeOutputs = os }+ info = NodeInfo { niName = f+ , niSafety = safe+ , niType = fun+ , niStaticParams = []+ , niProfile = prof1+ }+ a <- withNode info m+ pure (NodeParam safe fun f prof1, a)+++checkStaticParams :: [StaticParam] -> M a -> M ([StaticParam],a)+checkStaticParams = checkNested checkStaticParam++checkStaticArg :: StaticArg -> StaticParam -> M (StaticArg, StaticEnv)+checkStaticArg arg para =+ case arg of+ ArgRange r a1 -> inRange r (checkStaticArg a1 para)++ TypeArg t ->+ case para of+ TypeParam i ->+ do t1 <- checkType t+ pure (TypeArg t1, sType i t1)+ _ -> mismatch++ ExprArg e ->+ case para of+ ConstParam x t ->+ do e' <- checkConstExpr e t+ pure (ExprArg e', sConst x e')+ _ -> mismatch++ NodeArg notationTy ni ->+ case para of+ NodeParam safe fun _ prof ->+ do ni1 <- checkStaticNodeArg ni safe fun prof+ pure (NodeArg notationTy ni1, sEmpty)+ _ -> mismatch+ where+ mismatch = reportError $ nestedError+ "Invalid static argument."+ [ "Expected:" <+> pDoc+ , "Got:" <+> aDoc+ ]++ aDoc = case arg of+ ExprArg {} -> "a constant expression"+ TypeArg {} -> "a type"+ NodeArg {} -> "a node"+ ArgRange {} -> panic "aDoc" ["Unexpected `ArgRange`"]++ pDoc = case para of+ TypeParam {} -> "a type"+ ConstParam {} -> "a constant expression"+ NodeParam {} -> "a node"+++checkStaticNodeArg ::+ NodeInst -> Safety -> NodeType -> NodeProfile -> M NodeInst+checkStaticNodeArg (NodeInst c as) safe fun prof =+ case c of+ CallUser f ->+ do (ni,iprof) <- prepUserNodeInst f as safe fun+ checkStaticArgTypes iprof prof+ pure ni++ -- The prims are all safe so we don't need to pass the safety+ CallPrim _r _op ->+ notYetImplemented "Passing primitives as static arguments."++prepUserNodeInst ::+ Name -> [StaticArg] -> Safety -> NodeType -> M (NodeInst, NodeProfile)+prepUserNodeInst f as safe fun =+ do fi <- lookupNodeInfo f+ inRange (range f) $+ do checkSafetyType fi safe fun+ checkEnoughStaticArgs fi as+ (as1,envs) <- unzip <$>+ zipWithM checkStaticArg as (niStaticParams fi)+ let env = sJoin envs+ iprof = instantiateProfile env (niProfile fi)+ pure (NodeInst (CallUser f) as1, iprof)++++checkStaticArgTypes :: NodeProfile -> NodeProfile -> M ()+checkStaticArgTypes actual expected =+ do unless (haveInNum == needInNum) $+ reportError $ nestedError+ "Incorrect number of inputs."+ [ "Parameter has" <+> int needInNum <+> "inputs."+ , "Given argument has" <+> int haveInNum <+> "inputs."+ ]+ unless (haveOutNum == needOutNum) $+ reportError $ nestedError+ "Incorrect number of outputs."+ [ "Parameter has" <+> int needOutNum <+> "outputs."+ , "Given argument has" <+> int haveOutNum <+> "outputs."+ ]+ zipWithM_ checkIn (nodeInputs actual) (nodeInputs expected)+ zipWithM_ checkOut (nodeOutputs actual) (nodeOutputs expected)++ where+ haveInNum = length (nodeInputs actual)+ haveOutNum = length (nodeOutputs actual)+ needInNum = length (nodeInputs expected)+ needOutNum = length (nodeOutputs expected)++ checkIn arg param =+ case (arg,param) of+ (InputConst _ t, InputConst _ t1) -> subType t1 t+ (InputBinder b, InputBinder b1) -> subCType (binderType b1) (binderType b)+ (InputBinder {}, InputConst {}) ->+ reportError "Expected a constant input."+ (InputConst {}, InputBinder {}) ->+ reportError "Unexpected constant input." -- XXX: perhaps this is ok?++ checkOut arg param = subCType (binderType arg) (binderType param)++ subCType x y =+ do subType (cType x) (cType y)+ sameClock (cClock x) (cClock y)+++++--------------------------------------------------------------------------------+{- Example:++f <<const n : int>> (x : Array n bool) returns (y : int)+g <<node z (x : Array 2 bool) returns (y : int)>> (...) returns (...)++g << f<<2>> >>++NOTE: for the moment we assume that node static arguments don't appear in types.+-}++data StaticEnv = StaticEnv+ { sConsts :: Map OrigName Expression+ , sTypes :: Map OrigName Type+ }++sEmpty :: StaticEnv+sEmpty = StaticEnv { sConsts = Map.empty, sTypes = Map.empty }++sType :: Ident -> Type -> StaticEnv+sType x t = sEmpty { sTypes = Map.singleton (identOrigName x) t }++sConst :: Ident -> Expression -> StaticEnv+sConst x e = sEmpty { sConsts = Map.singleton (identOrigName x) e }++sJoin :: [StaticEnv] -> StaticEnv+sJoin envs = StaticEnv { sConsts = Map.unions (map sConsts envs)+ , sTypes = Map.unions (map sTypes envs)+ }++--------------------------------------------------------------------------------++instantiateProfile :: StaticEnv -> NodeProfile -> NodeProfile+instantiateProfile env prof =+ NodeProfile+ { nodeInputs = map (instantiateInputBinder env) (nodeInputs prof)+ , nodeOutputs = map (instantiateBinder env) (nodeOutputs prof)+ }++instantiateInputBinder :: StaticEnv -> InputBinder -> InputBinder+instantiateInputBinder env inp =+ case inp of+ InputConst x t -> InputConst x (instantiateType env t)+ InputBinder b -> InputBinder (instantiateBinder env b)++instantiateBinder :: StaticEnv -> Binder -> Binder+instantiateBinder env b =+ b { binderType =+ CType { cType = instantiateType env (cType ct)+ , cClock = case cClock ct of+ BaseClock -> BaseClock+ KnownClock c -> KnownClock (iClock c)+ ClockVar i -> ClockVar i+ }+ }+ where+ ct = binderType b+ iClock (WhenClock r e i) = WhenClock r (instantiateConst env e) i+++-- | Instantiate a type with the given static parameters.+instantiateType :: StaticEnv -> Type -> Type+instantiateType env ty+ | Map.null (sConsts env) && Map.null (sTypes env) = ty -- a very common case+ | otherwise =+ case ty of+ ArrayType t e -> ArrayType (iType t) (iConst e)+ NamedType x -> Map.findWithDefault ty (nameOrigName x) (sTypes env)+ TypeRange r t -> TypeRange r (iType t)+ IntSubrange e1 e2 -> IntSubrange (iConst e1) (iConst e2)+ IntType -> ty+ RealType -> ty+ BoolType -> ty+ where+ iType = instantiateType env+ iConst = instantiateConst env+++{- | Instantiate a constant with the given static parameters.+These are just constants that can appear in types, so pretty much+an expression denoting an `int`. However, to support selectors and functions+we pretty much do all but the temporal constructs. -}+instantiateConst :: StaticEnv -> Expression -> Expression+instantiateConst env expr+ | Map.null (sConsts env) && Map.null (sTypes env) = expr -- a very common case+ | otherwise =+ case expr of+ ERange r e -> ERange r (iConst e)+ Var x -> Map.findWithDefault expr (nameOrigName x) (sConsts env)+ Lit {} -> expr++ Select e s -> Select (iConst e) (iSelect s)+ Tuple es -> Tuple (map iConst es)+ Array es -> Array (map iConst es)+ Struct s fs -> Struct (iStructTy s) (map iField fs)+ UpdateStruct s e fs ->+ UpdateStruct (iStructTy <$> s) (iConst e) (map iField fs)++ WithThenElse e1 e2 e3 -> WithThenElse (iConst e1) (iConst e2) (iConst e3)+ Call (NodeInst n as) es BaseClock tys ->+ Call (NodeInst n (map iArg as)) (map iConst es) BaseClock tys+ Call {} -> bad "call with a clock"++ When {} -> bad "WhenClock"+ Merge {} -> bad "Merge"+ Const {} -> panic "instantiateConst" [ "Unexpected `Const`" ]++ where+ bad x = panic "instantiateConst" [ "Unexpected construct: " ++ x ]++ iStructTy x = toNameTy (iType (NamedType x))+ toNameTy ty = case ty of+ TypeRange _ t -> toNameTy t+ NamedType t -> t+ _ -> bad "Struct type was not a named type?"++ iConst = instantiateConst env+ iType = instantiateType env+ iSelect sel =+ case sel of+ SelectField {} -> sel+ SelectElement e -> SelectElement (iConst e)+ SelectSlice s -> SelectSlice (iSlice s)+ iSlice sl = ArraySlice { arrayStart = iConst (arrayStart sl)+ , arrayEnd = iConst (arrayEnd sl)+ , arrayStep = iConst <$> arrayStep sl+ }++ iField f = f { fValue = iConst (fValue f) }+ iArg arg = case arg of+ TypeArg t -> TypeArg (iType t)+ ExprArg e -> ExprArg (iConst e)+ NodeArg t ni -> NodeArg t (iInst ni)+ ArgRange r s -> ArgRange r (iArg s)+ iInst (NodeInst f as) = NodeInst f (map iArg as)++++checkSafetyType :: NodeInfo -> Safety -> NodeType -> M ()+checkSafetyType ni safe fun =+ do case (safe, niSafety ni) of+ (Safe, Unsafe) ->+ reportError ("Invalid unsafe node parameter" <+> fDoc)+ _ -> pure ()+ case (fun, niType ni) of+ (Function, Node) ->+ reportError ("Expected a function parameter, but"+ <+> fDoc <+> "is a node.")+ _ -> pure ()+ where+ fDoc = backticks (pp (niName ni))+++checkEnoughStaticArgs :: NodeInfo -> [StaticArg] -> M ()+checkEnoughStaticArgs ni as =+ case compare have need of+ EQ -> pure ()+ LT -> reportError+ ("Not enough static arguments in call to"+ <+> backticks (pp (niName ni)))+ GT -> reportError $+ ("Too many static arguments in call to"+ <+> backticks (pp (niName ni)))+ where+ have = length as+ need = length (niStaticParams ni)++++checkNodeBody :: NodeBody -> M NodeBody+checkNodeBody nb = addLocals (nodeLocals nb)+ where+ {- NOTE: there are all kinds of things that one could check here, if+ we intentd to run the Lustre program. For example, all variables should+ have definitions, and maybe we don't want recursive equations.+ However, when using Lustre as a front-end to a model checker, it is sometimes+ conveninet to relax such issues. In that case we think of the equations+ more in their math form: not so much LHS is defined by RHS, but rather+ we'd just like them to be equal. With that mind set it makes sense to+ allow partial specifications, and even recursive ones: the result may+ be that we transition to multiple next states (i.e., we are no longer+ deterministic), or perhaps we get stuck (e.g., if a recursive equation+ has no fixed point).+ -}++ addLocals ls =+ case ls of+ [] -> do es <- mapM checkEquation (nodeEqns nb)+ pure NodeBody { nodeLocals = [], nodeEqns = es }+ l : more ->+ do (d,n) <- checkLocalDecl l (addLocals more)+ pure n { nodeLocals = d : nodeLocals n }++checkLocalDecl :: LocalDecl -> M a -> M (LocalDecl,a)+checkLocalDecl ld m =+ case ld of+ LocalVar b -> apFstM LocalVar (checkBinder b m)+ LocalConst c -> apFstM LocalConst (checkConstDef c m)+++checkConstDef :: ConstDef -> M a -> M (ConstDef, a)+checkConstDef c m =+ do (c1,t) <- checkDef+ addFst c1 (withConst (constName c) t m)+ where+ checkDef =+ inRange (range (constName c)) $+ case constDef c of+ Nothing ->+ case constType c of+ Nothing -> reportError $ nestedError+ "Constant declaration with no type or default."+ [ "Name:" <+> pp (constName c) ]+ Just t -> do t1 <- checkType t+ pure (c { constType = Just t }, t1)++ Just e ->+ do (e',t) <- case constType c of+ Nothing -> inferConstExpr e+ Just t -> do t' <- checkType t+ e' <- checkConstExpr e t'+ pure (e',t')+ pure (c { constType = Just t, constDef = Just e' }, t)++checkInputBinder :: InputBinder -> M a -> M (InputBinder, a)+checkInputBinder ib m =+ case ib of+ InputBinder b -> apFstM InputBinder (checkBinder b m)+ InputConst i t ->+ do t1 <- checkType t+ addFst (InputConst i t1) (withConst i t1 m)++checkBinder :: Binder -> M a -> M (Binder,a)+checkBinder b m =+ do c <- case cClock (binderType b) of+ BaseClock -> pure BaseClock+ KnownClock e -> do (e',_) <- inferClockExpr e+ pure (KnownClock e')+ ClockVar i -> panic "checkBinder"+ [ "Unexpected clock variable: " ++ showPP i ]+ t <- checkType (cType (binderType b))+ let ty = CType { cType = t, cClock = c }+ newB = b { binderType = ty }+ addFst newB $ withLocal (binderDefines b) ty m++checkInputBinders :: [InputBinder] -> M a -> M ([InputBinder],a)+checkInputBinders = checkNested checkInputBinder++checkOutputBinders :: [Binder] -> M a -> M ([Binder],a)+checkOutputBinders = checkNested checkBinder++addFst :: a -> M b -> M (a,b)+addFst a m =+ do b <- m+ pure (a,b)++apFstM :: (a -> x) -> M (a,b) -> M (x,b)+apFstM f m =+ do (a,b) <- m+ pure (f a, b)++checkNested :: (forall a. t -> M a -> M (t,a)) -> [t] -> M b -> M ([t],b)+checkNested work things m =+ case things of++ [] ->+ do a <- m+ pure ([],a)++ t : ts ->+ do (t1,(ts1,a)) <- work t (checkNested work ts m)+ pure (t1:ts1,a)++--------------------------------------------------------------------------------+++-- | Validate a type.+checkType :: Type -> M Type+checkType ty =+ case ty of+ TypeRange _ t -> checkType t+ IntType -> pure IntType+ BoolType -> pure BoolType+ RealType -> pure RealType+ IntSubrange x y ->+ do a <- checkConstExpr x IntType+ b <- checkConstExpr y IntType+ leqConsts x y+ pure (IntSubrange a b)+ NamedType x -> resolveNamed x+ ArrayType t n ->+ do n1 <- checkConstExpr n IntType+ leqConsts (Lit (Int 0)) n1+ t1 <- checkType t+ pure (ArrayType t1 n1)+++-- | Validate an equation.+checkEquation :: Equation -> M Equation+checkEquation eqn =+ enterRange $+ case eqn of+ Assert l ty e ->+ do (e',clk) <- checkExpr1 e BoolType+ sameClock BaseClock clk -- do we want to support others?+ pure (Assert l ty e')++ Property l e ->+ do (e',clk) <- checkExpr1 e BoolType+ sameClock BaseClock clk -- do we want to support others?+ pure (Property l e')++ IsMain _ -> pure eqn++ IVC _ -> pure eqn -- XXX: what should we check here?++ Realizable _ -> pure eqn -- XXX: what should we check here?++ Define ls e ->+ do (ls',lts) <- unzip <$> mapM inferLHS ls+ (e',cts) <- inferExpr e+ sameLen lts cts+ for_ (zip lts cts) $ \(lt,ct) ->+ do sameClock (cClock lt) (cClock ct)+ subType (cType ct) (cType lt)+ pure (Define ls' e')++ where+ enterRange = case eqnRangeMaybe eqn of+ Nothing -> id+ Just r -> inRange r+++-- | Infer the type of the left-hand-side of a declaration.+inferLHS :: LHS Expression -> M (LHS Expression, CType)+inferLHS lhs =+ case lhs of+ LVar i -> do t <- lookupLocal i+ pure (LVar i, t)+ LSelect l s ->+ do (l1,t) <- inferLHS l+ (s1,t1) <- inferSelector s (cType t)+ pure (LSelect l1 s1, t { cType = t1 })++++{- | Infer the type of an expression.+Tuples and function calls may return multiple results,+which is why we provide multiple clocked types. -}+inferExpr :: Expression -> M (Expression, [CType])+inferExpr expr =+ case expr of+ ERange r e -> inRange r (inferExpr e)++ Var x ->+ inRange (range x) $+ do (e1,ct) <- inferVar x+ pure (e1,[ct])++ Lit l ->+ do let ty = inferLit l+ c <- newClockVar+ let ct = CType { cType = ty, cClock = c }+ pure (Const (Lit l) ct, [ct])++ e `When` c ->+ do checkTemporalOk "when"+ (c',ct1) <- inferClockExpr c+ (e',ct2s) <- inferExpr e+ cts <- for ct2s $ \ct ->+ do sameClock (cClock ct) (cClock ct1)+ pure ct { cClock = KnownClock c' }+ pure (e' `When` c', cts)++ Tuple es ->+ do (es',cts) <- unzip <$> mapM inferExpr1 es+ pure (Tuple es',cts)++ Array es ->+ do (es',cts) <- unzip <$> mapM inferExpr1 es+ let ne = Lit $ Int $ fromIntegral $ length es+ done c t =+ do let ct = CType { cClock = c, cType = ArrayType t ne }+ pure (Array es', [ct])+ case cts of+ [] -> notYetImplemented "Empty arrays"+ elT : more ->+ do t <- foldM tLUB (cType elT) (map cType more)+ mapM_ (sameClock (cClock elT)) (map cClock more)+ done (cClock elT) t++ Select e s ->+ do (e',recCT) <- inferExpr1 e+ (s',ty) <- inferSelector s (cType recCT)+ let ct = recCT { cType = ty }+ pure (Select e' s', [ct])++ Struct s fs ->+ do (e',ct) <- inferStruct s fs+ pure (e',[ct])++ UpdateStruct s e fs ->+ do (e',ct) <- inferStructUpdate s e fs+ pure (e',[ct])++ WithThenElse e1 e2 e3 ->+ do e1' <- checkConstExpr e1 BoolType+ (e2',ct1) <- inferExpr e2+ (e3',ct2) <- inferExpr e3+ sameLen ct1 ct2+ ct <- zipWithM ctLUB ct1 ct2+ pure (WithThenElse e1' e2' e3', ct)++ Merge i as ->+ do ctI <- lookupLocal i+ (as',ctss) <- unzip <$> for as (inferMergeCase i (cType ctI))+ case ctss of+ [] -> reportError "Empty merge case"+ ctAlt : alts ->+ do for_ alts (sameLen ctAlt)+ let byCol = transpose (map (map cType) ctss)+ cts <- for byCol $ \ ~(t:ts) ->+ do t1 <- foldM tLUB t ts+ pure CType { cClock = cClock ctI, cType = t1 }+ pure (Merge i as',cts)++ Call _ _ _ (Just {}) ->+ panic "inferExpr" ["Got a call that already has types", show expr]++ Call (NodeInst call as) es cl Nothing ->+ case call of+ CallUser f -> inferCall f as es cl+ CallPrim r prim+ | BaseClock <- cl -> inferPrim r prim as es+ | otherwise -> reportError "Unexpected clock annotation in call"++ Const {} -> panic "inferExpr" [ "Unexpected `Const` expression." ]+++-- | Infer the type of an expression that should not return multiple results.+inferExpr1 :: Expression -> M (Expression,CType)+inferExpr1 e =+ do (e',cts) <- inferExpr e+ ct <- one cts+ pure (e',ct)++{- | Infer the type of a constant expression.+NOTE: the elaborated result will contain `Const` annotations,+which is a little bogus, but they will go away in the `NoStatic pass. -}+inferConstExpr :: Expression -> M (Expression,Type)+inferConstExpr expr =+ allowTemporal False $+ allowUnsafe False $+ do (e',ct) <- inferExpr1 expr+ sameClock BaseClock (cClock ct)+ pure (e',cType ct)++-- | Infer the type of a constant expression.+checkConstExpr :: Expression -> Type -> M Expression+checkConstExpr expr ty =+ do (e',t) <- inferConstExpr expr+ subType t ty+ pure e'++checkExpr1 :: Expression -> Type -> M (Expression,IClock)+checkExpr1 e t =+ do (e',ct) <- inferExpr1 e+ subType (cType ct) t+ pure (e', cClock ct)++++{- | Ensure that the given named type is a struct. If so, get the real+name of the struct (e.g., if the original was an alias for a struct),+and alsot its fields, in declaration order. -}+checkStructType :: Name -> M (Name, [FieldType])+checkStructType s =+ do ty <- checkType (NamedType s)+ let name = case ty of+ NamedType nm -> nm+ _ -> panic "checkStructType"+ [ "Unexpected struct type ellaboration:"+ , "*** Struct type: " ++ showPP s+ , "*** Result: " ++ showPP ty+ ]+ fs <- lookupStruct name+ pure (name,fs)+++-- | Infer the type of a struct formaing expression.+inferStruct :: Name -> [Field Expression] -> M (Expression,CType)+inferStruct s fs =+ do distinctFields fs+ (s',fExpect) <- checkStructType s+ let fieldMap = Map.fromList [ (fName f, f) | f <- fs ]+ i <- newClockVar+ fs' <- for fExpect $ \ft ->+ case Map.lookup (fieldName ft) fieldMap of++ Nothing -> -- Field not initialized+ case fieldDefault ft of+ Nothing -> reportError $+ "Field" <+> backticks (pp (fieldName ft)) <+>+ "of" <+> backticks (pp s') <+>+ "is not initialized."+ Just e1 ->+ let ct = CType { cType = fieldType ft, cClock = i }+ in pure Field { fName = fieldName ft+ , fValue = Const e1 ct+ }++ Just f -> -- Field initialized+ do (e,clk) <- checkExpr1 (fValue f) (fieldType ft)+ sameClock i clk+ pure f { fValue = e }++ let ct = CType { cClock = i, cType = NamedType s' }+ pure (Struct s' fs', ct)+++-- | Infer a structure updatating expression.+inferStructUpdate ::+ Maybe Name -> Expression -> [Field Expression] -> M (Expression,CType)+inferStructUpdate mbS e fs =+ do distinctFields fs+ (e',ct) <- inferExpr1 e+ (actualName, fieldTs) <-+ case mbS of+ Just s -> checkStructType s+ Nothing ->+ case cType ct of+ NamedType name ->+ do fTs <- lookupStruct name+ pure (name,fTs)+ _ -> reportError $ nestedError+ "Invalid struct update."+ [ "Expression is not a struct." ]++ fs' <- for fs $ \f ->+ case find ((fName f ==) . fieldName) fieldTs of++ Just ft ->+ do (fv,fclk) <- checkExpr1 (fValue f) (fieldType ft)+ sameClock fclk (cClock ct)+ pure f { fValue = fv }++ Nothing -> reportError $+ "Struct" <+> backticks (pp actualName) <+>+ "does not have a field" <+> backticks (pp (fName f))++ pure (UpdateStruct (Just actualName) e' fs', ct)++++-- | Check that all of the fields are different.+distinctFields :: [Field Expression] -> M ()+distinctFields = mapM_ check . group . sort . map fName+ where+ check g =+ case g of+ [] -> panic "distinctFields" ["`group` returned an empty list?"]+ [_] -> pure ()+ f : _ -> reportError $ nestedError+ ("Repeated occurances of field" <+> backticks (pp f))+ (map (pp . range) g)+++++-- | Infer the type of a call to a user node.+inferCall :: Name ->+ [StaticArg] ->+ [Expression] ->+ IClock ->+ M (Expression, [CType])+inferCall f as es0 cl0 =+ do reqSafety <- getUnsafeLevel+ reqTemporal <- getTemporalLevel+ cl <- case cl0 of+ BaseClock -> pure BaseClock+ KnownClock c ->+ case reqTemporal of+ Node -> KnownClock . fst <$> inferClockExpr c+ Function -> reportError $ nestedError+ "Invalid clocked call"+ [ "Expected to be inside a node."+ , "We are inside a function."+ ]+ ClockVar i -> panic "inferCall" [ "Unexpected clock variable:"+ , showPP i ]++ (ni,prof) <- prepUserNodeInst f as reqSafety reqTemporal+ (es1,mp) <- checkInputs cl [] Map.empty (nodeInputs prof) es0+ cts <- checkOuts cl mp (nodeOutputs prof)+ pure (Call ni es1 cl (Just cts), cts)+ where+ renBinderClock cl mp b =+ case cClock (binderType b) of+ BaseClock -> pure cl++ KnownClock (WhenClock r p i) ->+ -- We don't consider `cl` for binder that have an explicit clock,+ -- as it only affects the "base" clock. Of course, the clocks will+ -- probably be inderectly affected anyway as the clock of the clock+ -- would change (etc.).+ case Map.lookup i mp of+ Just (Right j) -> pure (KnownClock (WhenClock r p j))+ Just (Left l) | matches p -> pure BaseClock+ where matches v = case v of+ ERange _ v1 -> matches v1+ Lit l1 -> l == l1+ _ -> False+ _ -> reportError $+ text ("Parameter for clock " ++ show (backticks (pp i)) +++ " is not an identifier.")++ ClockVar i -> panic "inferCall.renBinderClock"+ [ "Unexpected clock variable", showPP i ]++ checkInputs cl done mp is es =+ case (is,es) of+ ([],[]) -> pure (reverse done,mp)+ (b:bs,c:cs) -> do (e,mp1) <- checkIn cl mp b c+ checkInputs cl (e:done) mp1 bs cs+ _ -> reportError $ nestedError+ ("Bad arity in call to" <+> pp f)+ [ "Expected:" <+> int (length done + length is)+ , "Actual:" <+> int (length done + length es)+ ]++ checkIn cl mp ib e =+ case ib of+ InputBinder b ->+ do c <- renBinderClock cl mp b+ (e',clk) <- checkExpr1 e (cType (binderType b))+ sameClock c clk+ pure ( e'+ , case isClock e' of+ Just k -> Map.insert (binderDefines b) k mp+ Nothing -> mp+ )+ InputConst _ t ->+ do e' <- checkConstExpr e t+ pure (e',mp)++ isClock e =+ case e of+ ERange _ e1 -> isClock e1+ Var (Unqual i) -> Just (Right i)+ Const (Lit l) _ -> Just (Left l)+ _ -> Nothing++ checkOuts cl mp bs = mapM (checkOut cl mp) bs++ checkOut cl mp b =+ do let t = binderType b+ c <- renBinderClock cl mp b+ pure t { cClock = c }++++++-- | Infer the type of a variable.+inferVar :: Name -> M (Expression,CType)+inferVar x =+ inRange (range x) $+ case x of+ Unqual i ->+ case rnThing (nameOrigName x) of+ AVal -> do ct <- lookupLocal i+ pure (Var (Unqual i), ct)+ AConst -> do t1 <- lookupConst x+ c <- newClockVar+ let ct = CType { cType = t1, cClock = c }+ pure (Const (Var x) ct, ct)++ t -> panic "inferVar" [ "Identifier is not a value or a constnat:"+ , "*** Name: " ++ showPP x+ , "*** Thing: " ++ showPP t ]++ Qual {} -> panic "inferVar" [ "Unexpected qualified name"+ , "*** Name: " ++ showPP x ]+++-- | Infer the type of a literal.+inferLit :: Literal -> Type+inferLit lit =+ case lit of+ Int _ -> IntSubrange (Lit lit) (Lit lit)+ Real _ -> RealType+ Bool _ -> BoolType+++-- | Validate a clock expression, and return the type of the clock.+inferClockExpr :: ClockExpr -> M (ClockExpr, CType)+inferClockExpr (WhenClock r v i) =+ inRange r $+ do ct <- lookupLocal i+ v' <- checkConstExpr v (cType ct)+ pure (WhenClock r v' i, ct)+++-- | Infer the type of a branch in a @merge@.+inferMergeCase ::+ Ident {- ^ The clock to merge on -} ->+ Type {- ^ The type of the clock -} ->+ MergeCase Expression {- ^ The branch to check -} ->+ M (MergeCase Expression, [CType])+inferMergeCase i it (MergeCase p e) =+ do p' <- checkConstExpr p it+ let clk = KnownClock (WhenClock (range p') p' i)+ (e', cts) <- inferExpr e+ for_ cts (sameClock clk . cClock)+ pure (MergeCase p' e', cts)++++-- | Infer the type of a selector.+inferSelector :: Selector Expression -> Type -> M (Selector Expression, Type)+inferSelector sel ty =+ case sel of+ SelectField f ->+ case ty of+ NamedType a ->+ do fs <- lookupStruct a+ case find ((f ==) . fieldName) fs of+ Just fi -> pure (sel,fieldType fi)+ Nothing ->+ reportError $+ nestedError+ "Struct has no such field:"+ [ "Struct:" <+> pp a+ , "Field:" <+> pp f ]++ _ -> reportError $+ nestedError+ "Argument to struct selector is not a struct:"+ [ "Selector:" <+> pp sel+ , "Input:" <+> pp ty+ ]++ SelectElement n ->+ case ty of+ ArrayType t _sz ->+ do n1 <- checkConstExpr n IntType+ -- XXX: check that 0 <= && n < sz ?+ pure (SelectElement n1, t)++ _ -> reportError $+ nestedError+ "Argument to array selector is not an array:"+ [ "Selector:" <+> pp sel+ , "Input:" <+> pp ty+ ]++ SelectSlice _s ->+ case ty of+ ArrayType _t _sz -> notYetImplemented "array slices"+ _ -> reportError $+ nestedError+ "Arrgument to array slice is not an array:"+ [ "Selector:" <+> pp sel+ , "Input:" <+> pp ty+ ]+++checkContract :: Contract -> M Contract+checkContract c =+ do cis <- mapM checkContractItem (contractItems c)+ pure c { contractItems = cis }++checkContractItem :: ContractItem -> M ContractItem+checkContractItem ci =+ case ci of+ Assume l e ->+ do (e1,clk) <- checkExpr1 e BoolType+ sameClock BaseClock clk -- do we want to support others?+ pure (Assume l e1)++ Guarantee l e ->+ do (e1,clk) <- checkExpr1 e BoolType+ sameClock BaseClock clk -- do we want to support others?+ pure (Guarantee l e1)++ _ -> notYetImplemented "contract feature"++++++
+ Language/Lustre/TypeCheck.hs-boot view
@@ -0,0 +1,10 @@+module Language.Lustre.TypeCheck where++import Language.Lustre.AST(Expression,CType,Type,IClock)+import Language.Lustre.TypeCheck.Monad(M)++inferExpr :: Expression -> M (Expression,[CType])+inferExpr1 :: Expression -> M (Expression,CType)+checkConstExpr :: Expression -> Type -> M Expression+checkExpr1 :: Expression -> Type -> M (Expression, IClock)+
+ Language/Lustre/TypeCheck/Constraint.hs view
@@ -0,0 +1,248 @@+{-# Language OverloadedStrings #-}+module Language.Lustre.TypeCheck.Constraint where++import Text.PrettyPrint as PP+import Control.Monad(unless)++import Language.Lustre.AST+import Language.Lustre.TypeCheck.Monad+import qualified Language.Lustre.Semantics.Const as C+import Language.Lustre.Pretty+import Language.Lustre.Panic+++opError :: Doc -> [Type] -> Doc+opError op ins =+ nestedError "Failed to check that that the types support operation."+ (("Operation:" <+> op) : tys "Input" ins)+ where+ tys lab ts = [ lab <+> integer n PP.<> ":" <+> pp t+ | (n,t) <- [ 1 .. ] `zip` ts ]++-- | Compute the least upper bound of two types.+tLUB :: Type -> Type -> M Type+tLUB t1 t2 =+ case t1 of++ BoolType ->+ do subType t2 t1+ pure t1++ RealType ->+ do subType t2 t1+ pure t1++ IntType ->+ do subType t2 t1+ pure t1++ NamedType _ ->+ do subType t2 t1+ pure t1++ ArrayType elT1 sz1 ->+ case t2 of+ ArrayType elT2 sz2 ->+ do sameConsts sz1 sz2+ t <- tLUB elT1 elT2+ pure (ArrayType t sz1)+ _ -> err++ IntSubrange l1 h1 ->+ case t2 of+ IntType -> pure t2+ IntSubrange l2 h2 ->+ do (l3,h3) <- intervalUnion (l1,h1) (l2,h2)+ pure (IntSubrange l3 h3)+ _ -> err++ TypeRange {} -> panic "tLUB" [ "Unexpected `TypeRange`." ]++ where+ err = reportError (opError "find common type" [ t1, t2 ])+++-- | Computes the type of the result of a unariy arithmetic operator.+tArith1 :: SourceRange -> Op1 -> Type -> M Type+tArith1 r op t =+ case t of+ IntType -> pure IntType+ RealType -> pure RealType+ IntSubrange l h ->+ do (l1,h1) <- intervalFor1 r op (l,h)+ pure (IntSubrange l1 h1)+ _ -> reportError (opError (pp op) [t])+++-- | Computes the type of the result of a binary arithmetic operator.+tArith2 :: SourceRange -> Op2 -> Type -> Type -> M Type+tArith2 r op t1 t2 =+ case t1 of+ IntType -> subType t2 t1 >> pure t1+ RealType -> subType t2 RealType >> pure t1++ IntSubrange l1 h1 ->+ case t2 of+ IntType -> pure t2+ IntSubrange l2 h2 -> intervalFor2 r op (l1,h1) (l2,h2)+ _ -> err++ _ -> err++ where+ err = reportError (opError (pp op) [t1,t2])++++-- | Checks that the given types can be compared for equality.+classEq :: Doc -> Type -> Type -> M ()+classEq _op s t =+ do _ <- tLUB s t -- we can compare values of any comparable type.+ -- XXX: Perhaps it is useful to save the common type?+ pure ()+++-- | Are these types comparable for ordering+classOrd :: Doc -> Type -> Type -> M ()+classOrd op s t =+ do r <- tLUB s t+ case r of+ IntType -> pure ()+ IntSubrange {} -> pure ()+ RealType -> pure ()+ _ -> reportError (opError op [s,t])+++-- | Subtype is like "subset" (i.e., we want to make sure that all values+-- of the first type are also good values for the second type).+subType :: Type -> Type -> M ()+subType s t =+ case (s,t) of+ (IntSubrange {}, IntType) -> pure ()+ (IntSubrange a b, IntSubrange c d) -> leqConsts c a >> leqConsts b d++ (ArrayType elT1 sz1, ArrayType elT2 sz2) ->+ do sameConsts sz1 sz2+ subType elT1 elT2++ (IntType,IntType) -> pure ()+ (RealType,RealType) -> pure ()+ (BoolType,BoolType) -> pure ()+ (NamedType x, NamedType y) | x == y -> pure ()+ _ -> reportError $ nestedError+ "Type mismatch:"+ [ "Values of type:" <+> pp s+ , "Do not fit into type:" <+> pp t+ ]+++++--------------------------------------------------------------------------------+++-- XXX: This is temporary. Eventually, we should make proper constraints,+-- and either try to solve them statically, or just generate them for the+-- checker to verify on each step.+++evConstExpr :: Expression -> Maybe C.Value+evConstExpr expr =+ case C.evalConst C.emptyEnv expr of+ Left _ -> Nothing+ Right v -> Just v++normConstExpr :: Expression -> Expression+normConstExpr expr =+ case evConstExpr expr of+ Nothing -> expr+ Just v -> C.valToExpr v++intConst :: Expression -> M Integer+intConst e =+ case evConstExpr e of+ Just (C.VInt a) -> pure a+ _ -> reportError $ nestedError+ "Constant expression is not a concrete integer."+ [ "Expression:" <+> pp e ]++intInterval :: (Expression,Expression) -> M (Integer,Integer)+intInterval (l,h) =+ do i <- intConst l+ j <- intConst h+ pure (i,j)++fromIntInterval :: (Integer,Integer) -> M (Expression,Expression)+fromIntInterval (l,h) = pure (Lit (Int l), Lit (Int h))++++sameConsts :: Expression -> Expression -> M ()+sameConsts e1 e2 =+ case (e1,e2) of+ (ERange _ x,_) -> sameConsts x e2+ (_, ERange _ x) -> sameConsts e1 x+ (Const x _, _) -> sameConsts x e2+ (_, Const x _) -> sameConsts e1 x+ (Var x, Var y) | x == y -> pure ()+ _ | x <- evConstExpr e1+ , y <- evConstExpr e2+ , x == y -> pure ()++ _ -> reportError $ nestedError+ "Constants do not match"+ [ "Constant 1:" <+> pp e1+ , "Constant 2:" <+> pp e2+ ]++leqConsts :: Expression -> Expression -> M ()+leqConsts e1 e2 =+ do x <- intConst e1+ y <- intConst e2+ unless (x <= y) $ reportError+ $ pp x <+> "is not less-than, or equal to" <+> pp y++++intervalFor1 :: SourceRange -> Op1 ->+ (Expression,Expression) ->+ M (Expression,Expression)+intervalFor1 _ op i =+ do (l,h) <- intInterval i+ case op of+ Neg -> fromIntInterval (negate h, negate l)+ _ -> panic "intervalFor1" [ "Unexpected unary arithmetic operator"+ , showPP op ]+++intervalFor2 :: SourceRange -> Op2 ->+ (Expression,Expression) ->+ (Expression,Expression) ->+ M Type+intervalFor2 _ op i j =+ do u@(l1,h1) <- intInterval i+ v@(l2,h2) <- intInterval j+ case op of+ Add -> rng (l1 + l2, h1 + h2)+ Sub -> rng (l1 - h2, h1 - l2)+ Mul -> byCases u v (*)+ Div -> pure IntType -- XXX: more precise?+ Mod -> pure IntType -- XXX: more precise+ _ -> panic "intervalFor2" [ "Unexpected binary arithmetic operator"+ , showPP op ]+ where+ rng u = do (a,b) <- fromIntInterval u+ pure (IntSubrange a b)++ byCases (a,b) (x,y) f = rng (minimum ch, maximum ch)+ where ch = [ f u v | u <- [a, b], v <- [x, y] ]++intervalUnion :: (Expression,Expression) ->+ (Expression,Expression) ->+ M (Expression,Expression)+intervalUnion i j =+ do (l1,h1) <- intInterval i+ (l2,h2) <- intInterval j+ fromIntInterval (min l1 l2, max h1 h2)++
+ Language/Lustre/TypeCheck/Monad.hs view
@@ -0,0 +1,420 @@+{-# Language OverloadedStrings, GeneralizedNewtypeDeriving, DataKinds #-}+module Language.Lustre.TypeCheck.Monad where++import Data.Set(Set)+import qualified Data.Set as Set+import Data.Map(Map)+import qualified Data.Map as Map+import Data.Foldable(for_)+import Text.PrettyPrint as PP+import MonadLib++import Language.Lustre.Name+import Language.Lustre.AST+import Language.Lustre.Pretty+import Language.Lustre.Monad (LustreM, LustreError(..))+import qualified Language.Lustre.Monad as L+import Language.Lustre.Panic++-- | XXX: Parameterize so that we can startin in a non-empty environment.+runTC :: M a -> LustreM a+runTC m =+ do (a,_finS) <- runStateT rw0 $ runReaderT ro0 $ unM m+ -- L.logMessage "Clock subst:"+ -- dumpClockSubstLustre (rwClockVarSubst _finS)+ pure a+ where+ ro0 = RO { roConstants = Map.empty+ , roUserNodes = Map.empty+ , roIdents = Map.empty+ , roCurRange = []+ , roTypeNames = Map.empty+ , roTemporal = False+ , roUnsafe = False+ }++ rw0 = RW { rwClockVarSubst = Map.empty+ , rwClockVars = Set.empty+ }+++++newtype M a = M { unM ::+ WithBase LustreM+ [ ReaderT RO+ , StateT RW+ ] a+ } deriving (Functor,Applicative,Monad)++-- | Information about a node that can be called (i.e., is in scope)+data NodeInfo = NodeInfo+ { niName :: Ident -- ^ Definition site+ , niSafety :: Safety -- ^ Safe/unsafe+ , niType :: NodeType -- ^ Function/node+ , niStaticParams :: [StaticParam] -- ^ Static parametres+ , niProfile :: NodeProfile -- ^ Inputs and ouputs+ }++data RO = RO+ { roConstants :: Map OrigName (SourceRange, Type)+ -- ^ Constants that are in scope. These include top-level constants,+ -- constant (i.e., static) parameters, and local constants.++ , roUserNodes :: Map OrigName NodeInfo+ -- ^ User defined nodes in scope, as well as static node parameters.++ , roIdents :: Map OrigName (SourceRange, CType)+ -- ^ Locals in scope (i.e., arguments and node locals)++ , roTypeNames :: Map OrigName (SourceRange, NamedType) -- no type vars here+ -- ^ Named types in scope (top level declarations plus static parameters)++ , roCurRange :: [SourceRange]+ -- ^ The "path" of locations that lead us to where we currently are.++ , roTemporal :: Bool+ -- ^ Are temporal constructs OK?++ , roUnsafe :: Bool+ -- ^ Are unsafe constucts OK?+ }+++data RW = RW+ { rwClockVarSubst :: Map CVar IClock+ , rwClockVars :: Set CVar+ -- ^ Clock variables in the current node.+ -- Ones that don't get bound are defaulted to the base clocks.+ }++data NamedType = StructTy [FieldType]+ -- ^ Order of the fields should match declaration+ | EnumTy (Set OrigName)+ | AliasTy Type+ | AbstractTy+++reportError :: Doc -> M a+reportError msg =+ M $ do rs <- roCurRange <$> ask+ inBase $ L.reportError $ TCError rs msg++notYetImplemented :: Doc -> M a+notYetImplemented f =+ reportError $ nestedError "XXX: Feature not yet implemented:"+ [ "Feature:" <+> f ]++nestedError :: Doc -> [Doc] -> Doc+nestedError x ys = vcat (x : [ "***" <+> y | y <- ys ])++inRange :: SourceRange -> M a -> M a+inRange r (M a) = M (mapReader upd a)+ where upd ro = ro { roCurRange = r : roCurRange ro }++inRangeSet :: SourceRange -> M a -> M a+inRangeSet r (M a) = M (mapReader upd a)+ where upd ro = ro { roCurRange = [r] }++inRangeSetMaybe :: Maybe SourceRange -> M a -> M a+inRangeSetMaybe mb m = case mb of+ Nothing -> m+ Just r -> inRangeSet r m++inRangeMaybe :: Maybe SourceRange -> M a -> M a+inRangeMaybe mb m = case mb of+ Nothing -> m+ Just r -> inRange r m++lookupLocal :: Ident -> M CType+lookupLocal i =+ do ro <- M ask+ let orig = identOrigName i+ case Map.lookup orig (roIdents ro) of+ Nothing -> panic "lookupLocal"+ [ "Undefined identifier: " ++ showPP i ]+ Just (_,t) -> pure t+++lookupConst :: Name -> M Type+lookupConst c =+ do ro <- M ask+ case Map.lookup (nameOrigName c) (roConstants ro) of+ Nothing -> panic "lookupConst" [ "Undefined constant: " ++ showPP c ]+ Just (_,t) -> pure t+++resolveNamed :: Name -> M Type+resolveNamed x =+ do ro <- M ask+ case Map.lookup (nameOrigName x) (roTypeNames ro) of+ Nothing -> panic "resolveNamed" [ "Undefined type:" ++ showPP x ]+ Just (_,nt) -> pure $ case nt of+ AliasTy t -> t+ _ -> NamedType x++lookupStruct :: Name -> M [FieldType]+lookupStruct s =+ do ro <- M ask+ case Map.lookup (nameOrigName s) (roTypeNames ro) of+ Nothing -> panic "lookupStruct" [ "Undefined struct: " ++ showPP s ]+ Just (_,nt) ->+ case nt of+ StructTy fs -> pure fs+ EnumTy {} -> reportError $ nestedError+ "Enumeration used where a struct was expected."+ [ "Type:" <+> pp s ]+ AliasTy at ->+ case at of+ NamedType s' -> lookupStruct s'+ _ -> reportError $ nestedError+ "Type is not a struct."+ [ "Type name:" <+> pp s+ , "Type definition:" <+> pp at+ ]++ AbstractTy -> reportError $ nestedError+ "Abstract type used where a struct was expected."+ ["Name:" <+> pp s]+++lookupNodeInfo :: Name -> M NodeInfo+lookupNodeInfo n =+ do ro <- M ask+ case Map.lookup (nameOrigName n) (roUserNodes ro) of+ Just info -> pure info+ Nothing -> panic "lookupNodeProfile" [ "Undefined node: " ++ showPP n ]++withConst :: Ident -> Type -> M a -> M a+withConst x t (M m) =+ do ro <- M ask+ let nm = identOrigName x+ let cs = roConstants ro+ M (local ro { roConstants = Map.insert nm (range x,t) cs } m)+++withLocal :: Ident -> CType -> M a -> M a+withLocal i t (M m) =+ M $ do ro <- ask+ let is = roIdents ro+ nm = identOrigName i+ local ro { roIdents = Map.insert nm (range i, t) is } m++withNode :: NodeInfo -> M a -> M a+withNode ni (M m) =+ M $ do ro <- ask+ let nm = identOrigName (niName ni)+ local ro { roUserNodes = Map.insert nm ni (roUserNodes ro) } m++withNamedType :: Ident -> NamedType -> M a -> M a+withNamedType x t (M m) =+ M $ do ro <- ask+ let nm = identOrigName x+ local ro { roTypeNames = Map.insert nm (range x,t)+ (roTypeNames ro) } m+++withLocals :: [(Ident,CType)] -> M a -> M a+withLocals xs k =+ case xs of+ [] -> k+ (x,t) : more -> withLocal x t (withLocals more k)++allowTemporal :: Bool -> M a -> M a+allowTemporal b (M m) = M (mapReader upd m)+ where upd ro = ro { roTemporal = b }++checkTemporalOk :: Doc -> M ()+checkTemporalOk msg =+ do ok <- M (roTemporal <$> ask)+ unless ok $+ reportError $ nestedError+ "Temporal operators are not allowed in a function."+ [ "Operator:" <+> msg ]++getTemporalLevel :: M NodeType+getTemporalLevel =+ do ok <- M (roTemporal <$> ask)+ pure (if ok then Node else Function)++allowUnsafe :: Bool -> M a -> M a+allowUnsafe b (M m) = M (mapReader upd m)+ where upd ro = ro { roUnsafe = b }++getUnsafeLevel :: M Safety+getUnsafeLevel =+ do ok <- M (roUnsafe <$> ask)+ pure (if ok then Unsafe else Safe)++++-- | Generate a fresh clock variable.+newClockVar :: M IClock+newClockVar = M $+ do n <- inBase L.newInt+ let cv = CVar n+ sets_ $ \rw -> rw { rwClockVars = Set.insert cv (rwClockVars rw) }+ pure (ClockVar cv)+++-- | Assumes that the clock is zonked+bindClockVar :: CVar -> IClock -> M ()+bindClockVar x c =+ case c of+ ClockVar y | x == y -> pure ()+ _ -> do let upd cl = case cl of+ ClockVar i | i == x -> c+ _ -> cl+ M $ sets_ $ \rw -> rw { rwClockVarSubst = Map.insert x c+ $ fmap upd+ $ rwClockVarSubst rw+ , rwClockVars = Set.delete x (rwClockVars rw)+ }++dumpClockSubst :: M ()+dumpClockSubst = M $+ do su <- rwClockVarSubst <$> get+ lift $ lift $ dumpClockSubstLustre su++dumpClockSubstLustre :: Map CVar IClock -> LustreM ()+dumpClockSubstLustre su =+ for_ (Map.toList su) $ \(x,v) ->+ L.logMessage (show (pp x <+> ":=" <+> pp v))++debugMessage :: String -> M ()+debugMessage s = M $ lift $ lift $ L.logMessage s+++-- | Generate a new scope of clock variables. Variables that are not defined+-- by the parameter computation will be defaulted to "base clock"+inClockScope :: M a -> M a+inClockScope (M m) = M $+ do old <- sets $ \rw -> (rwClockVars rw, rw { rwClockVars = Set.empty })+ a <- m+ leftover <- rwClockVars <$> get+ let mp = Map.fromList [ (x,BaseClock) | x <- Set.toList leftover ]+ sets_ $ \rw -> rw { rwClockVars = old+ , rwClockVarSubst = Map.union mp (rwClockVarSubst rw)+ }+ pure a++++zonkClock :: IClock -> M IClock+zonkClock c =+ case c of+ BaseClock -> pure c+ KnownClock (WhenClock r v i) ->+ do v' <- zonkExpr v+ case isId v' of+ Just j | i == j -- clocks that are always true+ -> pure BaseClock+ _ -> pure (KnownClock (WhenClock r v' i))+ ClockVar v -> M $ do su <- rwClockVarSubst <$> get+ pure (Map.findWithDefault c v su)+ where+ isId e = case e of+ ERange _ e1 -> isId e1+ Const e' _ -> isId e'+ Var (Unqual x) -> Just x+ _ -> Nothing++++-- | Apply the substitution to types in the AST.+-- Currently, only the 'Const' construct contains a type.+zonkExpr :: Expression -> M Expression+zonkExpr expr =+ case expr of+ ERange r e -> ERange r <$> zonkExpr e+ Const e ty -> Const <$> zonkExpr e <*> zonkCType ty+ Var {} -> pure expr+ Lit {} -> pure expr+ e `When` c -> When <$> zonkExpr e <*> zonkClockExpr c++ Tuple es -> Tuple <$> traverse zonkExpr es+ Array es -> Array <$> traverse zonkExpr es+ Select e s -> Select <$> zonkExpr e <*> zonkSelector s+ Struct s fs -> Struct s <$> traverse zonkField fs+ UpdateStruct s e fs -> UpdateStruct s+ <$> zonkExpr e+ <*> traverse zonkField fs+ WithThenElse e1 e2 e3 -> WithThenElse <$> zonkExpr e1 <*>+ zonkExpr e2 <*> zonkExpr e3+ Merge i as -> Merge i <$> traverse zonkMergeCase as+ Call f es c mTys -> Call f <$> traverse zonkExpr es <*> zonkClock c <*>+ case mTys of+ Nothing -> return Nothing+ Just tys -> Just <$> mapM zonkCType tys++zonkCType :: CType -> M CType+zonkCType ct =+ do t <- zonkType (cType ct)+ c <- zonkClock (cClock ct)+ pure CType { cType = t, cClock = c }++zonkType :: Type -> M Type+zonkType t =+ case t of+ ArrayType elT sz -> ArrayType <$> zonkType elT <*> zonkExpr sz+ IntSubrange e1 e2 -> IntSubrange <$> zonkExpr e1 <*> zonkExpr e2+ NamedType {} -> pure t+ RealType -> pure t+ IntType -> pure t+ BoolType -> pure t+ TypeRange r t' -> TypeRange r <$> zonkType t'++zonkField :: Field Expression -> M (Field Expression)+zonkField f =+ do e <- zonkExpr (fValue f)+ pure f { fValue = e }++zonkMergeCase :: MergeCase Expression -> M (MergeCase Expression)+zonkMergeCase (MergeCase k e) = MergeCase <$> zonkExpr k <*> zonkExpr e++zonkSelector :: Selector Expression -> M (Selector Expression)+zonkSelector sel =+ case sel of+ SelectField {} -> pure sel+ SelectElement e -> SelectElement <$> zonkExpr e+ SelectSlice e -> SelectSlice <$> zonkSlice e++zonkSlice :: ArraySlice Expression -> M (ArraySlice Expression)+zonkSlice a =+ do s <- zonkExpr (arrayStart a)+ e <- zonkExpr (arrayEnd a)+ t <- traverse zonkExpr (arrayStep a)+ pure ArraySlice { arrayStart = s, arrayEnd = e, arrayStep = t }++zonkClockExpr :: ClockExpr -> M ClockExpr+zonkClockExpr (WhenClock r e i) =+ do e' <- zonkExpr e+ pure (WhenClock r e' i)++zonkBody :: NodeBody -> M NodeBody+zonkBody b =+ do eqs <- traverse zonkEqn (nodeEqns b)+ pure b { nodeEqns = eqs }++zonkEqn :: Equation -> M Equation+zonkEqn eqn =+ case eqn of+ Assert p ty e -> Assert p ty <$> zonkExpr e+ Property p e -> Property p <$> zonkExpr e+ IsMain {} -> pure eqn+ IVC {} -> pure eqn+ Realizable {} -> pure eqn+ Define lhs e -> Define lhs <$> zonkExpr e++zonkContract :: Contract -> M Contract+zonkContract c =+ do cis <- mapM zonkContractItem (contractItems c)+ pure c { contractItems = cis }++zonkContractItem :: ContractItem -> M ContractItem+zonkContractItem ci =+ case ci of+ Assume l e -> Assume l <$> zonkExpr e+ Guarantee l e -> Guarantee l <$> zonkExpr e+ _ -> panic "zonkContractItem" ["unsupported contract item"]+
+ Language/Lustre/TypeCheck/Prims.hs view
@@ -0,0 +1,252 @@+{-# Language OverloadedStrings #-}+module Language.Lustre.TypeCheck.Prims ( inferPrim ) where++import Data.Traversable(for)+import Data.Foldable(for_)+import Text.PrettyPrint+import Control.Monad(unless,zipWithM)++import Language.Lustre.AST+import Language.Lustre.Pretty+import Language.Lustre.TypeCheck.Monad+import Language.Lustre.TypeCheck.Constraint+import {-# SOURCE #-} Language.Lustre.TypeCheck+import Language.Lustre.TypeCheck.Utils+++-- | Infer the type of a call to a primitive node.+inferPrim ::+ SourceRange {- ^ Location of operator -} ->+ PrimNode {- ^ Operator -} ->+ [StaticArg] {- ^ Static arguments -} ->+ [Expression] {- ^ Normal argumetns -} ->+ M (Expression,[CType])+inferPrim r prim as es =+ case prim of++ Iter {} -> notYetImplemented "iterators."++ Op1 op ->+ case es of+ [e] -> noStatic op >> inferOp1 r op e+ _ -> reportError (pp op <+> "expects 1 argument.")++ Op2 op ->+ case es of+ [e1,e2] -> noStatic op >> inferOp2 r op e1 e2+ _ -> reportError (pp op <+> "expects 2 arguments.")++ ITE ->+ case es of+ [e1,e2,e3] -> noStatic ITE >> inferITE r e1 e2 e3+ _ -> reportError "`if-then-else` expects 3 arguments."+++ OpN op -> noStatic op >> inferOpN r op es+ where+ noStatic op =+ unless (null as) $+ reportError (backticks (pp op) <+> "does not take static arguments")+++-- | Check an if-then-else expression.+inferITE :: SourceRange -> Expression -> Expression -> Expression ->+ M (Expression,[CType])+inferITE r e1 e2 e3 =+ do (e1',c) <- checkExpr1 e1 BoolType+ (e2',ctTHEN) <- inferExpr e2+ (e3',ctELSE) <- inferExpr e3+ sameLen ctTHEN ctELSE+ for_ ctTHEN (sameClock c . cClock)+ for_ ctELSE (sameClock c . cClock)+ ts <- zipWithM tLUB (map cType ctTHEN) (map cType ctELSE)+ let cts = [ CType { cClock = c, cType = t } | t <- ts ]+ pure (eITE r e1' e2' e3' (Just cts), cts)++++-- | Check a @current@ expression.+inferCurrent :: Expression -> M (Expression,[CType])+inferCurrent e =+ do checkTemporalOk "current"+ (e',ctsIn) <- inferExpr e+ cts <- for ctsIn $ \ct -> do c <- clockParent (cClock ct)+ pure ct { cClock = c }+ pure (e',cts)+++-- | Check a uniary operator.+inferOp1 :: SourceRange -> Op1 -> Expression -> M (Expression,[CType])+inferOp1 r op e =+ do (a, ct) <- check+ pure (eOp1 r op a (Just ct), ct)++ where+ check =+ case op of++ Pre ->+ do checkTemporalOk "pre"+ inferExpr e++ Current -> inferCurrent e++ Not ->+ do (e', i) <- checkExpr1 e BoolType+ let ct = CType { cType = BoolType, cClock = i }+ pure (e', [ct])++ Neg ->+ do (e', ct0) <- inferExpr1 e+ t <- tArith1 r op (cType ct0)+ let ct = CType { cClock = cClock ct0, cType = t }+ pure (e', [ct])++ IntCast ->+ do (e', i) <- checkExpr1 e RealType+ let ct = CType { cType = IntType, cClock = i }+ pure (e', [ct])++ FloorCast ->+ do (e', i) <- checkExpr1 e RealType+ let ct = CType { cType = IntType, cClock = i }+ pure (e', [ct])++ RealCast ->+ do (e', i) <- checkExpr1 e IntType+ let ct = CType { cType = RealType, cClock = i }+ pure (e', [ct])+++-- | Types of binary operators.+inferOp2 ::+ SourceRange -> Op2 -> Expression -> Expression -> M (Expression,[CType])+inferOp2 r op2 e1 e2 =+ do (a, b, cts) <- check+ pure (eOp2 r op2 a b (Just cts), cts)++ where+ check =+ case op2 of+ FbyArr -> inferFBY "->"+ Fby -> inferFBY "fby"++ CurrentWith ->+ do checkTemporalOk "currentWith"+ (a,ctDEF) <- inferExpr e1+ (b,ctEXP) <- inferCurrent e2+ sameLen ctDEF ctEXP+ cts <- zipWithM ctLUB ctDEF ctEXP+ pure (a, b, cts)++ Replicate ->+ do (a,ctE) <- inferExpr1 e1+ b <- checkConstExpr e2 IntType+ let ct = ctE { cType = ArrayType (cType ctE) b }+ pure (a, b, [ct])++ And -> bool2+ Or -> bool2+ Xor -> bool2+ Implies -> bool2++ Eq -> eqRel "="+ Neq -> eqRel "<>"++ Lt -> ordRel "<"+ Leq -> ordRel "<="+ Gt -> ordRel ">"+ Geq -> ordRel ">="++ Add -> arith Add+ Sub -> arith Sub+ Mul -> arith Mul+ Div -> arith Div+ Mod -> arith Mod++ Power -> notYetImplemented "Exponentiation"+ Concat -> inferConcat+++ inferFBY x =+ do checkTemporalOk x+ (a,cts1) <- inferExpr e1+ (b,cts2) <- inferExpr e2+ sameLen cts1 cts2+ ct <- zipWithM ctLUB cts1 cts2+ pure (a, b, ct)+++ infer2 = do (a,t1) <- inferExpr1 e1+ (b,t2) <- inferExpr1 e2+ sameClock (cClock t1) (cClock t2)+ pure (cClock t1, cType t1, cType t2, a, b)++ bool2 = do (c,t1,t2,a,b) <- infer2+ _ <- subType t1 BoolType+ _ <- subType t2 BoolType+ let ct = CType { cType = BoolType, cClock = c }+ pure (a, b, [ct])++ ordRel op = do (c,t1,t2,a,b) <- infer2+ _ <- classOrd op t1 t2+ let ct = CType { cType = BoolType, cClock = c }+ pure (a, b, [ct])++ arith x = do (c,t1,t2,a,b) <- infer2+ ty <- tArith2 r x t1 t2+ let ct = CType { cType = ty, cClock = c }+ pure (a, b, [ct])++ eqRel op = do (a,cts1) <- inferExpr e1+ (b,cts2) <- inferExpr e2+ sameLen cts1 cts2+ for_ (zip cts1 cts2) $ \(ct1,ct2) ->+ do sameClock (cClock ct1) (cClock ct2)+ classEq op (cType ct1) (cType ct2)+ i <- case cts1 of+ [] -> newClockVar+ ct : _ -> pure (cClock ct)+ let ct = CType { cType = BoolType, cClock = i }+ pure (a, b, [ct])++ inferConcat =+ do (a, ct1) <- inferExpr1 e1+ (b, ct2) <- inferExpr1 e2+ sameClock (cClock ct1) (cClock ct2)+ let t1 = cType ct1+ t2 = cType ct2+ case t1 of+ ArrayType elT1 sz1 ->+ case t2 of+ ArrayType elT2 sz2 ->+ do t <- tLUB elT1 elT2+ sz <- addExprs sz1 sz2+ let ct = CType { cType = ArrayType t sz, cClock = cClock ct1 }+ pure (a,b,[ct])+ _ -> typeError "right" t2+ _ -> typeError "left" t1+ where++ typeError x t = reportError $ nestedError+ ("Incorrect" <+> x <+> "argument to `|`")+ [ "Expected:" <+> "array"+ , "Actual type:" <+> pp t ]+++-- | Check a variable arity operator.+inferOpN :: SourceRange -> OpN -> [Expression] -> M (Expression,[CType])+inferOpN r op es =+ case op of+ AtMostOne -> boolOp+ Nor -> boolOp+ where+ boolOp =+ do (es',cts) <- unzip <$> for es inferExpr1+ i <- newClockVar+ for_ cts (sameClock i . cClock)+ let ct = CType { cClock = i, cType = BoolType }+ pure (eOpN r op es' (Just [ct]),[ct])+++
+ Language/Lustre/TypeCheck/Utils.hs view
@@ -0,0 +1,114 @@+{-# Language OverloadedStrings #-}+module Language.Lustre.TypeCheck.Utils where++import Text.PrettyPrint+import Control.Monad(unless)++import Language.Lustre.AST+import Language.Lustre.Pretty+import Language.Lustre.TypeCheck.Monad+import Language.Lustre.TypeCheck.Constraint+++-- | Assert that a given expression has only one type (i.e., is not a tuple)+one :: [a] -> M a+one xs =+ case xs of+ [x] -> pure x+ _ -> arityMismatch (length xs) 1++sameLen :: [a] -> [b] -> M ()+sameLen xs ys+ | a == b = pure ()+ | otherwise = arityMismatch a b+ where+ a = length xs+ b = length ys++arityMismatch :: Int -> Int -> M a+arityMismatch x y =+ reportError $+ nestedError "Arity mismatch."+ [ "Expected arity:" <+> int x+ , "Actual arity:" <+> int y+ ]++ctLUB :: CType -> CType -> M CType+ctLUB ct1 ct2 =+ do sameClock (cClock ct1) (cClock ct2)+ ty <- tLUB (cType ct1 )(cType ct2)+ pure CType { cClock = cClock ct1, cType = ty }++++--------------------------------------------------------------------------------+-- Clocks+++-- | Are these the same clock. If so, return the one that is NOT a 'ConstExpr'+-- (if any).+sameClock :: IClock -> IClock -> M ()+sameClock x0 y0 =+ do x <- zonkClock x0+ y <- zonkClock y0+ case (x,y) of+ (ClockVar a, _) -> bindClockVar a y+ (_, ClockVar a) -> bindClockVar a x+ (BaseClock,BaseClock) -> pure ()+ (KnownClock a, KnownClock b) -> sameKnownClock a b+ _ -> reportError $ nestedError+ "The given clocks are different:"+ [ "Clock 1:" <+> pp x+ , "Clock 2:" <+> pp y+ ]++-- | Is this the same known clock.+sameKnownClock :: ClockExpr -> ClockExpr -> M ()+sameKnownClock c1@(WhenClock _ e1_init i1) c2@(WhenClock _ e2_init i2) =+ do unless (i1 == i2) $+ reportError $+ nestedError+ "The given clocks are different:"+ [ "Clock 1:" <+> pp c1+ , "Clock 2:" <+> pp c2+ ]+ sameConsts e1_init e2_init++-- | Get the clock of a clock, or fail if we are the base clock.+clockParent :: IClock -> M IClock+clockParent ct0 =+ do ct <- zonkClock ct0+ case ct of+ BaseClock -> reportError "The base clock has no parent."+ KnownClock (WhenClock _ _ i) -> cClock <$> lookupLocal i+ -- XXX: This can be a constnat?+ ClockVar _ -> reportError "Failed to infer the expressions's clock"++++--------------------------------------------------------------------------------+-- Expressions++binConst :: (Integer -> Integer -> Integer) ->+ Expression -> Expression -> M Expression+binConst f e1 e2 =+ do x <- intConst e1+ y <- intConst e2+ pure $ Lit $ Int $ f x y++addExprs :: Expression -> Expression -> M Expression+addExprs = binConst (+) -- XXX: Can make an expression instead++minExprs :: Expression -> Expression -> M Expression+minExprs = binConst min++maxConsts :: Expression -> Expression -> M Expression+maxConsts = binConst max++++++++
+ Language/Lustre/Utils.hs view
@@ -0,0 +1,15 @@+module Language.Lustre.Utils where++import Language.Lustre.Panic+import Language.Lustre.Pretty++-- | Like 'zipWith' except panic if the lists have different lenghts.+zipExact :: (Pretty a, Pretty b) => (a -> b -> c) -> [a] -> [b] -> [c]+zipExact f xs ys+ | length xs == length ys = zipWith f xs ys+ | otherwise = panic "zipExact"+ $ "MISMATCH"+ : "--- LHS: ---"+ : map showPP xs+ ++ ("--- RHS: ---" : map showPP ys)+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ exe/Lustre.hs view
@@ -0,0 +1,143 @@+{-# Language OverloadedStrings #-}+module Main(main) where++import Text.Read(readMaybe)+import Text.PrettyPrint((<+>))+import Control.Exception(catches,Handler(..),throwIO,catch)+import Control.Monad(when,unless)+import Data.IORef(newIORef,readIORef,writeIORef)+import System.IO(stdin,stdout,stderr,hFlush,hPutStrLn,hPrint+ , openFile, IOMode(..), hGetContents )+import System.IO.Error(isEOFError,mkIOError,eofErrorType)+import System.Exit(exitSuccess)+import qualified Data.Map as Map+import Numeric(readSigned,readFloat)+import SimpleGetOpt+import qualified Data.Set as Set++import Language.Lustre.AST(Program(..))+import Language.Lustre.Core+import Language.Lustre.Semantics.Core+import Language.Lustre.Parser(parseProgramFromFileLatin1, ParseError)+import Language.Lustre.Driver+import Language.Lustre.Monad+import Language.Lustre.Pretty(pp)++import Options+++computeConf :: Options -> IO LustreConf+computeConf opts =+ do logH <- case logFile opts of+ Nothing -> pure stdout+ Just f -> openFile f WriteMode+ pure LustreConf { lustreInitialNameSeed = Nothing+ , lustreLogHandle = logH+ , lustreDumpAfter = dumpAfter opts+ }+++main :: IO ()+main =+ do opts <- getOptsX options+ when (showHelp opts) $+ do putStrLn (usageString options)+ exitSuccess++ a <- case progFile opts of+ Nothing ->+ throwIO (GetOptException ["No Lustre file was specified."])+ Just f -> parseProgramFromFileLatin1 f++ case a of+ ProgramDecls ds ->+ do conf <- computeConf opts+ (ws,nd) <- runLustre conf $+ do unless (Set.null (lustreDumpAfter conf))+ (setVerbose True)+ (_,nd) <- quickNodeToCore Nothing ds+ warns <- getWarnings+ pure (warns,nd)+ mapM_ showWarn ws+ sIn <- newIn (inputFile opts)+ runNodeIO (dumpState opts) sIn nd+ _ -> hPutStrLn stderr "We don't support packages for the moment."+ `catches`+ [ Handler $ \e -> showErr (e :: ParseError)+ , Handler $ \e -> showErr (e :: LustreError)+ , Handler $ \(GetOptException es) ->+ do mapM_ (hPutStrLn stderr) es+ hPutStrLn stderr ""+ hPutStrLn stderr (usageString options)++ ]+ where+ showErr e = hPrint stderr (pp e)+ showWarn w = hPrint stderr (pp w)+++data In = In+ { nextToken :: IO String+ , echo :: Bool+ }++newIn :: Maybe FilePath -> IO In+newIn mb =+ do (h,e) <- case mb of+ Nothing -> pure (stdin,False)+ Just f -> do h <- openFile f ReadMode+ pure (h,True)+ ws0 <- words <$> hGetContents h+ r <- newIORef ws0+ pure In { nextToken = -- assumes single threaded+ do ws <- readIORef r+ case ws of+ [] -> ioError $ mkIOError eofErrorType+ "(EOF)" Nothing Nothing+ w : more -> do writeIORef r more+ pure w+ , echo = e+ }++runNodeIO :: Bool -> In -> Node -> IO ()+runNodeIO dumpS sIn node =+ go (1::Integer) s0+ `catch` \e -> if isEOFError e then putStrLn "(EOF)" else throwIO e+ where+ (s0,step) = initNode node Nothing++ go n s = do putStrLn ("--- Step " ++ show n ++ " ---")+ when dumpS $ print $ ppState ppinfo s+ s1 <- step s <$> getInputs+ mapM_ (showOut s1) (nOutputs node)+ go (n+1) s1++ showOut s (x ::: _) = print (pp x <+> "=" <+> ppValue (evalVar s x))++ getInputs = Map.fromList <$> mapM getInput (nInputs node)++ ppinfo = identVariants node++ getInput b@(x ::: ct) =+ do putStr (show (ppBinder ppinfo b <+> " = "))+ hFlush stdout+ txt <- nextToken sIn+ when (echo sIn) (putStrLn txt)+ case parseVal (typeOfCType ct) txt of+ Just ok -> pure (x,ok)+ Nothing -> do putStrLn ("Invalid " ++ show (ppCType ppinfo ct))+ getInput b++parseVal :: Type -> String -> Maybe Value+parseVal t s+ | ["-"] == words s = Just VNil+ | otherwise =+ case t of+ TBool -> VBool <$> readMaybe s+ TInt -> VInt <$> readMaybe s+ TReal -> case readSigned readFloat s of+ [(n,"")] -> Just (VReal n)+ _ -> Nothing+++
+ exe/Options.hs view
@@ -0,0 +1,79 @@+module Options where++import SimpleGetOpt+import Data.Set(Set)+import qualified Data.Set as Set++import Language.Lustre.Phase++data Options = Options+ { progFile :: Maybe FilePath+ , inputFile :: Maybe FilePath+ , logFile :: Maybe FilePath+ , dumpAfter :: Set LustrePhase+ , dumpState :: Bool+ , showHelp :: Bool+ }++defaultOptions :: Options+defaultOptions = Options+ { progFile = Nothing+ , inputFile = Nothing+ , logFile = Nothing+ , dumpAfter = noPhases+ , dumpState = False+ , showHelp = False+ }++options :: OptSpec Options+options = OptSpec+ { progDefaults = defaultOptions+ , progOptions =++ [ Option [] ["input"]+ "Read inputs from this file (default `stdin`)."+ $ ReqArg "FILE" $ \a s ->+ case inputFile s of+ Nothing -> Right s { inputFile = Just a }+ Just _ -> Left "Multiple input files."++ , Option [] ["logFile"]+ "Write messages to his file (default `stdout`)."+ $ ReqArg "FILE" $ \a s ->+ case logFile s of+ Nothing -> Right s { logFile = Just a }+ Just _ -> Left "Multiple log file."++ , Option [] ["dump-all"]+ "Dump AST after each phase."+ $ NoArg $ \s -> Right s { dumpAfter = allPhases }++ , dumpOpt PhaseRename "renamed" "renaming"+ , dumpOpt PhaseTypecheck "typechecked" "type checking"+ , dumpOpt PhaseNoStatic "no-static" "elimininating constants"+ , dumpOpt PhaseNoStruct "no-struct" "elimininating strucutred data"+ , dumpOpt PhaseInline "inlined" "inlining nodes"+ , dumpOpt PhaseToCore "core" "translating to core"++ , Option [] ["dump-state"]+ "Dump state before each step."+ $ NoArg $ \s -> Right s { dumpState = True }++ , Option [] ["help"]+ "Show this helps message."+ $ NoArg $ \s -> Right s { showHelp = True }++ ]++ , progParamDocs = [("FILE", "Lustre file containing model (required).")]+ , progParams = \a s -> case progFile s of+ Nothing -> Right s { progFile = Just a }+ _ -> Left "Multiple program files."+ }++ where+ dumpOpt ph o msg =+ Option [] ["dump-" ++ o]+ ("Dump AST after " ++ msg ++ ".")+ $ NoArg $ \s -> Right s { dumpAfter = Set.insert ph (dumpAfter s) }+
+ language-lustre.cabal view
@@ -0,0 +1,86 @@+name: language-lustre+version: 1.0.0+synopsis: A parser and AST for the Lustre language.+description: A parser and AST for the Lustre language (specifically Lustre V6).+license: ISC+license-file: LICENSE+author: Iavor Diatchki+maintainer: iavor.diatchki@gmail.com+category: Development+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++source-repository this+ type: git+ location: https://github.com/GaloisInc/lustre.git+ -- Add a tag for releases+ tag: v1.0.0++library+ exposed-modules: Language.Lustre.AST,+ Language.Lustre.Defines,+ Language.Lustre.Name,+ Language.Lustre.Monad,+ Language.Lustre.Error,+ Language.Lustre.Panic,+ Language.Lustre.Parser.Lexer,+ Language.Lustre.Parser,+ Language.Lustre.Parser.Monad,+ Language.Lustre.Pretty,+ Language.Lustre.Core,+ Language.Lustre.Utils,+ Language.Lustre.ModelState,+ Language.Lustre.Driver,+ Language.Lustre.Phase,++ Language.Lustre.TypeCheck,+ Language.Lustre.TypeCheck.Constraint,+ Language.Lustre.TypeCheck.Monad,+ Language.Lustre.TypeCheck.Prims,+ Language.Lustre.TypeCheck.Utils,++ Language.Lustre.Transform.OrderDecls,+ Language.Lustre.Transform.NoStatic,+ Language.Lustre.Transform.NoStruct,+ Language.Lustre.Transform.Inline,+ Language.Lustre.Transform.ToCore,++ Language.Lustre.Semantics.Const,+ Language.Lustre.Semantics.Value,+ Language.Lustre.Semantics.BuiltIn,+ Language.Lustre.Semantics.Core+++ build-depends: base >= 4.7 && < 5,+ alex-tools >=0.4,+ bytestring,+ text,+ array,+ panic,+ containers,+ GraphSCC,+ pretty,+ monadLib >= 3.8+ build-tools: alex, happy+ default-language: Haskell2010+ ghc-options: -Wall++executable lustre+ hs-source-dirs: exe+ main-is: Lustre.hs++ other-modules:+ Options++ build-depends:+ base,+ containers,+ pretty,+ simple-get-opt == 0.4.*,+ language-lustre++ ghc-options: -Wall+ default-language: Haskell2010++