copilot-core-4.3/0000755000000000000000000000000014762717257012167 5ustar0000000000000000copilot-core-4.3/README.md0000644000000000000000000000262314762717257013451 0ustar0000000000000000[![Build Status](https://travis-ci.com/Copilot-Language/copilot.svg?branch=master)](https://app.travis-ci.com/github/Copilot-Language/copilot) # Copilot: a stream DSL The core language, which efficiently represents Copilot expressions. The core is only of interest to implementers wishing to add a new back-end to Copilot. Copilot is a runtime verification framework written in Haskell. It allows the user to write programs in a simple but powerful way using a stream-based approach. Programs can be interpreted for testing, or translated C99 code to be incorporated in a project, or as a standalone application. The C99 backend ensures us that the output is constant in memory and time, making it suitable for systems with hard realtime requirements. ## Installation Copilot-core can be found on [Hackage](https://hackage.haskell.org/package/copilot-core). It is typically only installed as part of the complete Copilot distribution. For installation instructions, please refer to the [Copilot website](https://copilot-language.github.io). ## Further information For further information, install instructions and documentation, please visit the Copilot website: [https://copilot-language.github.io](https://copilot-language.github.io) ## License Copilot is distributed under the BSD-3-Clause license, which can be found [here](https://raw.githubusercontent.com/Copilot-Language/copilot/master/copilot-core/LICENSE). copilot-core-4.3/LICENSE0000644000000000000000000000263614762717257013203 0ustar00000000000000002009 BSD3 License terms Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of the developers nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. copilot-core-4.3/Setup.hs0000644000000000000000000000005614762717257013624 0ustar0000000000000000import Distribution.Simple main = defaultMain copilot-core-4.3/CHANGELOG0000644000000000000000000001405614762717257013407 0ustar00000000000000002025-03-07 * Version bump (4.3). (#604) * Fix typo in documentation. (#587) * Add a Show instance for Type. (#589) * Add a Prop type to capture how a property is quantified. (#254) 2025-01-07 * Version bump (4.2). (#577) * Deprecate fields of Copilot.Core.Expr.UExpr. (#565) * Increase test coverage. (#555) * Define generic implementations of Struct and Typed methods. (#564) 2024-11-07 * Version bump (4.1). (#561) * Add Haddocks for updateField. (#525) * Standardize changelog format. (#550) * Deprecate Copilot.Core.Type.UType.uTypeType. (#484) 2024-09-07 * Version bump (4.0). (#532) * Update Op3, Array to support array updates. (#36) 2024-07-07 * Version bump (3.20). (#522) * Update Op2, Struct to support struct field updates. (#520) 2024-05-07 * Version bump (3.19.1). (#512) 2024-03-07 * Version bump (3.19). (#504) * Remove deprecated functions in Copilot.Core.Type and Copilot.Core.Type.Array. (#500) * Increase test coverage. (#502) 2024-01-07 * Version bump (3.18.1). (#493) 2024-01-07 * Version bump (3.18). (#487) 2023-11-07 * Version bump (3.17). (#466) * Compliance with style guide. (#457) 2023-09-07 * Version bump (3.16.1). (#455) 2023-07-07 * Version bump (3.16). (#448) 2023-05-07 * Version bump (3.15). (#438) * Remove Copilot.Core.Type.Equality. (#427) * Remove Copilot.Core.PrettyPrint. (#426) 2023-03-07 * Version bump (3.14). (#422) * Remove Copilot.Core.PrettyDot. (#409) * Fix formatting error in CHANGELOG. (#414) * Remove module space Copilot.Core.Interpret. (#410) * Remove unused definitions from Copilot.Core.Type.Array. (#411) 2023-01-07 * Version bump (3.13). (#406) * Implement missing cases of type equality for arrays and structs. (#400) * Remove Copilot.Core.External. (#391) * Fix bug in definition of simpleType for Int8. (#393) * Hide module Copilot.Core.Type.Show. (#392) 2022-11-07 * Version bump (3.12). (#389) * Deprecate Copilot.Core.PrettyPrinter. (#383) * Replace uses of Copilot.Core.Type.Equality with definitions from base:Data.Type.Equality; deprecate Copilot.Core.Type.Equality. (#379) * Compliance with style guide. (#332) 2022-09-07 * Version bump (3.11). (#376) * Deprecate Copilot.Core.PrettyDot. (#359) * Remove Copilot.Core.Type.Dynamic. (#360) * Split copilot-interpreter into separate library. (#361) * Deprecate unused classes, functions from Array module. (#369) 2022-07-07 * Version bump (3.10). (#356) * Fix error in test case generation; enable CLI args in tests. (#337) * Remove unnecessary dependencies from Cabal package. (#324) * Deprecate Copilot.Core.External. (#322) * Remove duplicated compiler option. (#328) * Hide type Copilot.Core.Type.Show.ShowWit. (#348) * Deprecate Copilot.Core.Type.Show. (#330) * Update repo info in cabal file. (#333) 2022-05-06 * Version bump (3.9). (#320) * Compliance with style guide (partial). (#316) * Hide module Copilot.Core.Interpret.Render. (#303) * Remove Copilot.Core.Type.Dynamic.fromDynF,toDynF. (#301) * Hide module Copilot.Core.Error. (#300) * Remove Copilot.Core.Type.Uninitialized. (#302) * Remove Copilot.Core.Expr.Tag. (#304) 2022-03-07 * Version bump (3.8). (#298) * Replaces uses of the internal Dynamic with base:Data.Dynamic. (#266) * Mark package as uncurated to avoid modification. (#288) 2022-01-07 * Version bump (3.7). (#287) * Make imports explicit, reorganize imports. (#277) * Remove Copilot.Core.Type.Read. (#286) * Remove Copilot.Core.Type.Eq. (#285) * Remove Copilot.Core.Locals. (#284) * Deprecate Copilot.Core.Type.Show.ShowWit. (#283) * Remove Copilot.Core.Type.Show.showWit. (#282) 2021-11-07 * Version bump (3.6). (#264) * Deprecate Copilot.Core.Type.Dynamic.toDynF and fromDynF. (#269) * Deprecate copilot-core:Copilot.Core.Type.Uninitialized. (#270) * Deprecate export of copilot-core:Copilot.Core.Interpret.Render. (#268) * Replace uses of copilot-core's error reporting functions. (#267) * Introduce new ops atan2, ceiling, floor. (#246) * Add initial support for unit testing. (#256) * Deprecate unused type. (#260) * Remove deprecated module. (#250) * Fix outdated/broken links. (#252) 2021-08-19 * Version bump (3.5). (#247) * Update travis domain in README. (#222) * Remove commented code. (#15) * Update official maintainer. (#236) * Update source repo location. (#241) * Add I. Perez to author list. (#243) 2021-07-07 * Version bump (3.4). (#231) * Deprecated `Copilot.Core.Locals`. (#141) * Deprecated `Copilot.Core.Type.Read` module. (#144) * Deprecated `showWit`. (#140) * Deprecated `Copilot.Core.Type.Eq`. (#143) * Remove unused module `Copilot.Core.StructMarshal`. (#139) 2021-05-07 * Version bump (3.3). (#217) * Fix URL in bug-reports field in cabal file. (#215) * Deprecate unused module Copilot.Core.MakeTags. (#142) * Deprecate unused functions in Copilot.Core.PrettyDot. (#137) 2021-03-05 * Version bump (3.2.1). (#136) * Completed the documentation. (#145) 2020-12-06 * Version bump (3.2). (#65) * Fixed implementation of tysize for n-dimensional arrays. (#147) * Removed sorting of interpreter output. (#148) * Minor documentation fixes. (#149, #151) * Credits: @fdedden. 2019-11-22 * Version bump (3.1). (#46) * Eliminate random modules and generators. (#157) * Updated contact information for 'impossible' error. (#154) * Implement missing pretty printer for Index operator. (#155) copilot-core-4.3/copilot-core.cabal0000644000000000000000000000366414762717257015563 0ustar0000000000000000cabal-version: >=1.10 name: copilot-core version: 4.3 synopsis: An intermediate representation for Copilot. description: Intermediate representation for Copilot. . Copilot is a stream (i.e., infinite lists) domain-specific language (DSL) in Haskell that compiles into embedded C. Copilot contains an interpreter, multiple back-end compilers, and other verification tools. . A tutorial, examples, and other information are available at . author: Frank Dedden, Lee Pike, Robin Morisset, Alwyn Goodloe, Sebastian Niller, Nis Nordbyop Wegmann, Ivan Perez license: BSD3 license-file: LICENSE maintainer: Ivan Perez homepage: https://copilot-language.github.io bug-reports: https://github.com/Copilot-Language/copilot/issues stability: Experimental category: Language, Embedded build-type: Simple extra-source-files: README.md, CHANGELOG x-curation: uncurated source-repository head type: git location: https://github.com/Copilot-Language/copilot.git subdir: copilot-core library default-language: Haskell2010 hs-source-dirs: src ghc-options: -Wall -fno-warn-orphans build-depends: base >= 4.9 && < 5 exposed-modules: Copilot.Core Copilot.Core.Expr Copilot.Core.Operators Copilot.Core.Spec Copilot.Core.Type Copilot.Core.Type.Array test-suite unit-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: Test.Extra Test.Copilot.Core.Type Test.Copilot.Core.Type.Array build-depends: base , HUnit , QuickCheck , test-framework , test-framework-hunit , test-framework-quickcheck2 , copilot-core hs-source-dirs: tests default-language: Haskell2010 ghc-options: -Wall copilot-core-4.3/tests/0000755000000000000000000000000014762717257013331 5ustar0000000000000000copilot-core-4.3/tests/Main.hs0000644000000000000000000000072314762717257014553 0ustar0000000000000000-- | Test copilot-core. module Main where -- External imports import Test.Framework (Test, defaultMain) -- Internal library modules being tested import qualified Test.Copilot.Core.Type import qualified Test.Copilot.Core.Type.Array -- | Run all unit tests on copilot-core. main :: IO () main = defaultMain tests -- | All unit tests in copilot-core. tests :: [Test.Framework.Test] tests = [ Test.Copilot.Core.Type.tests , Test.Copilot.Core.Type.Array.tests ] copilot-core-4.3/tests/Test/0000755000000000000000000000000014762717257014250 5ustar0000000000000000copilot-core-4.3/tests/Test/Extra.hs0000644000000000000000000000227314762717257015673 0ustar0000000000000000-- | Auxiliary testing helper functions. module Test.Extra where -- External imports import Control.Arrow ((***)) -- * Function application -- | Apply a tuple with two functions to a tuple of arguments. apply1 :: (a1 -> b1, a2 -> b2) -- ^ Pair with functions -> (a1, a2) -- ^ Pair with arguments -> (b1, b2) -- ^ Pair with results apply1 = uncurry (***) -- | Apply a tuple with two functions on two arguments to their tupled -- arguments. apply2 :: (a1 -> b1 -> c1, a2 -> b2 -> c2) -- ^ Pair with functions -> (a1, a2) -- ^ Pair with first arguments -> (b1, b2) -- ^ Pair with second arguments -> (c1, c2) -- ^ Pair with results apply2 fs = apply1 . apply1 fs -- | Apply a tuple with two functions on three arguments to their tupled -- arguments. apply3 :: (a1 -> b1 -> c1 -> d1, a2 -> b2 -> c2 -> d2) -- ^ Pair with functions -> (a1, a2) -- ^ Pair with first arguments -> (b1, b2) -- ^ Pair with second arguments -> (c1, c2) -- ^ Pair with third arguments -> (d1, d2) -- ^ Pair with results apply3 fs = apply2 . apply1 fs copilot-core-4.3/tests/Test/Copilot/0000755000000000000000000000000014762717257015661 5ustar0000000000000000copilot-core-4.3/tests/Test/Copilot/Core/0000755000000000000000000000000014762717257016551 5ustar0000000000000000copilot-core-4.3/tests/Test/Copilot/Core/Type.hs0000644000000000000000000003406114762717257020032 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- | Test copilot-core:Copilot.Core.Type. module Test.Copilot.Core.Type where -- External imports import Data.Int (Int16, Int32, Int64, Int8) import Data.Maybe (isJust) import Data.Proxy (Proxy (..)) import Data.Type.Equality (TestEquality (..), testEquality, (:~:) (..)) import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeLits (sameSymbol) import Prelude as P import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck (Gen, Property, arbitrary, elements, expectFailure, forAll, forAllBlind, property, shuffle, (==>)) -- Internal imports: library modules being tested import Copilot.Core.Type (Field (..), SimpleType (..), Struct (..), Type (..), Typed, UType (..), Value (..), accessorName, fieldName, simpleType, typeLength, typeOf, typeSize) import Copilot.Core.Type.Array (Array) -- | All unit tests for copilot-core:Copilot.Core.Type. tests :: Test.Framework.Test tests = testGroup "Copilot.Core.Type" [ testProperty "simpleType preserves inequality" testSimpleTypesInequality , testProperty "reflexivity of equality of simple types" testSimpleTypesEqualityReflexive , testProperty "symmetry of equality of simple types" testSimpleTypesEqualitySymmetric , testProperty "transitivity of equality of simple types" testSimpleTypesEqualityTransitive , testProperty "uniqueness of equality of simple types" testSimpleTypesEqualityUniqueness , testProperty "typeLength matches array size for 1-dimensional arrays" testTypeLength1 , testProperty "typeLength matches array size for 2-dimensional arrays" testTypeLength2 , testProperty "typeSize matches full array size for 1-dimensional arrays" testTypeSize1 , testProperty "typeSize matches full array size for 2-dimensional arrays" testTypeSize2 , testProperty "equality of types" testUTypesEqualitySymmetric , testProperty "equality of utype" testUTypesEq , testProperty "inequality of utype" testUTypesInequality , testProperty "inequality of utype via typeOf" testUTypesTypeOfInequality , testProperty "inequality of different types" testTypesInequality , testProperty "fieldName matches field name (positive)" testFieldNameOk , testProperty "fieldName matches field name (negative)" testFieldNameFail , testProperty "Show field name" testShowField , testProperty "Show struct" testShowStruct , testProperty "Update struct" testUpdateStruct , testProperty "Update struct" testUpdateStructFail , testProperty "accessorName matches field name (positive)" testAccessorNameOk , testProperty "accessorName matches field name (negative)" testAccessorNameFail , testProperty "typeName matches struct type name (positive)" testTypeNameOk , testProperty "typeName matches struct type name (negative)" testTypeNameFail ] -- | Test that the function simpleTypes preserves inequality, that is, it -- returns different values for different types. This test is limited; we do -- not test structs or arrays. testSimpleTypesInequality :: Property testSimpleTypesInequality = forAllBlind twoDiffTypes $ \(t1, t2) -> t1 /= t2 where twoDiffTypes :: Gen (SimpleType, SimpleType) twoDiffTypes = do shuffled <- shuffle diffTypes case shuffled of (t1:t2:_) -> return (t1, t2) _ -> return (SBool, SBool) -- | A list of types that should all be different. diffTypes :: [SimpleType] diffTypes = [ simpleType Bool , simpleType Int8 , simpleType Int16 , simpleType Int32 , simpleType Int64 , simpleType Word8 , simpleType Word16 , simpleType Word32 , simpleType Word64 , simpleType Float , simpleType Double , simpleType (Array Int8 :: Type (Array 3 Int8)) , simpleType (Struct (S (Field 0) (Field 0))) ] -- | Test that the equality relation for simple types is reflexive. testSimpleTypesEqualityReflexive :: Property testSimpleTypesEqualityReflexive = forAllBlind (elements simpleTypes) $ \t -> t == t -- | Test that the equality relation for simple types is symmetric. testSimpleTypesEqualitySymmetric :: Property testSimpleTypesEqualitySymmetric = forAllBlind (elements simpleTypes) $ \t1 -> forAllBlind (elements simpleTypes) $ \t2 -> t1 == t2 ==> t2 == t1 -- | Test that the equality relation for simple types is transitive. testSimpleTypesEqualityTransitive :: Property testSimpleTypesEqualityTransitive = forAllBlind (elements simpleTypes) $ \t1 -> forAllBlind (elements simpleTypes) $ \t2 -> forAllBlind (elements simpleTypes) $ \t3 -> (t1 == t2 && t2 == t3) ==> (t1 == t3) -- | Test that each type is only equal to itself. testSimpleTypesEqualityUniqueness :: Property testSimpleTypesEqualityUniqueness = forAllBlind (shuffle simpleTypes) $ \(t:ts) -> notElem t ts -- | Simple types tested. simpleTypes :: [SimpleType] simpleTypes = [ SBool , SInt8 , SInt16 , SInt32 , SInt64 , SWord8 , SWord16 , SWord32 , SWord64 , SFloat , SDouble , SStruct , SArray Int8 , SArray Int16 ] -- | Test that the length of an array is as expected. testTypeLength1 :: Property testTypeLength1 = property $ typeLength a == 3 where a :: Type (Array 3 Int8) a = Array Int8 -- | Test that the length of an multi-dimensional array is as expected. testTypeLength2 :: Property testTypeLength2 = property $ typeLength a == 3 where a :: Type (Array 3 (Array 12 Int8)) a = Array (Array Int8) -- | Test that the size of an array is as expected. testTypeSize1 :: Property testTypeSize1 = property $ typeLength a == 3 where a :: Type (Array 3 Int8) a = Array Int8 -- | Test that the size of a multi-dimensional array is as expected (flattens -- the array). testTypeSize2 :: Property testTypeSize2 = property $ typeSize a == 36 where a :: Type (Array 3 (Array 12 Int8)) a = Array (Array Int8) -- | Test that equality is symmetric for UTypes via testEquality. testUTypesEqualitySymmetric :: Property testUTypesEqualitySymmetric = forAllBlind (elements utypes) $ \(UType t1) -> testEquality t1 t1 == Just Refl -- | Test that testEquality implies equality for UTypes. testUTypesEq :: Property testUTypesEq = forAllBlind (elements utypes) $ \t@(UType t1) -> (testEquality t1 t1 == Just Refl) ==> t == t -- | Test that any two different UTypes are not equal. -- -- This function pre-selects two UTypes from a list of different UTypes, which -- guarantees that they will be different. testUTypesInequality :: Property testUTypesInequality = forAllBlind twoDiffTypes $ \(t1, t2) -> t1 /= t2 where twoDiffTypes :: Gen (UType, UType) twoDiffTypes = do shuffled <- shuffle utypes case shuffled of (t1:t2:_) -> return (t1, t2) _ -> return (UType Bool, UType Bool) -- | Test that any two different Types are not equal. -- -- This function pre-selects two Types from a list of different UTypes, which -- guarantees that they will be different. testTypesInequality :: Property testTypesInequality = forAllBlind twoDiffTypes $ \(UType t1, UType t2) -> testEquality t1 t2 == Nothing where twoDiffTypes :: Gen (UType, UType) twoDiffTypes = do shuffled <- shuffle utypes case shuffled of (t1:t2:_) -> return (t1, t2) _ -> return (UType Bool, UType Bool) -- | Different UTypes. utypes :: [UType] utypes = [ UType Bool , UType Int8 , UType Int16 , UType Int32 , UType Int64 , UType Word8 , UType Word16 , UType Word32 , UType Word64 , UType Float , UType Double , UType a1 , UType a2 , UType a3 , UType a4 , UType b1 , UType b2 , UType b3 , UType b4 , UType c ] where a1 :: Type (Array 3 Int8) a1 = Array Int8 a2 :: Type (Array 4 Int8) a2 = Array Int8 a3 :: Type (Array 5 Int8) a3 = Array Int8 a4 :: Type (Array 6 Int8) a4 = Array Int8 b1 :: Type (Array 3 Int16) b1 = Array Int16 b2 :: Type (Array 4 Int16) b2 = Array Int16 b3 :: Type (Array 5 Int16) b3 = Array Int16 b4 :: Type (Array 6 Int16) b4 = Array Int16 c :: Type S c = Struct (S (Field 0) (Field 0)) -- | Test that any two different UTypes are not equal. -- -- This function pre-selects two UTypes from a list of different UTypes built -- via the function typeOf, which guarantees that they will be different. testUTypesTypeOfInequality :: Property testUTypesTypeOfInequality = forAllBlind twoDiffTypes $ \(t1@(UType t1'), t2@(UType t2')) -> -- The seqs are important: otherwise, the coverage goes down drastically -- because the typeOf function is not really executed. t1' `seq` t2' `seq` t1 /= t2 where twoDiffTypes :: Gen (UType, UType) twoDiffTypes = do shuffled <- shuffle uTypesTypeOf case shuffled of (t1:t2:_) -> t1 `seq` t2 `seq` return (t1, t2) _ -> return (UType Bool, UType Bool) -- | Different UTypes, produced by using the function typeOf. uTypesTypeOf :: [UType] uTypesTypeOf = [ UType (typeOf :: Type Bool) , UType (typeOf :: Type Int8) , UType (typeOf :: Type Int16) , UType (typeOf :: Type Int32) , UType (typeOf :: Type Int64) , UType (typeOf :: Type Word8) , UType (typeOf :: Type Word16) , UType (typeOf :: Type Word32) , UType (typeOf :: Type Word64) , UType (typeOf :: Type Float) , UType (typeOf :: Type Double) , UType (typeOf :: Type (Array 3 Int8)) , UType (typeOf :: Type (Array 3 Int16)) , UType (typeOf :: Type (Array 3 Int32)) , UType (typeOf :: Type (Array 3 Int64)) , UType (typeOf :: Type (Array 3 Word8)) , UType (typeOf :: Type (Array 3 Word16)) , UType (typeOf :: Type (Array 3 Word32)) , UType (typeOf :: Type (Array 3 Word64)) , UType (typeOf :: Type (Array 3 Double)) , UType (typeOf :: Type (Array 3 Float)) , UType (typeOf :: Type S) ] -- | Test the fieldName function (should succeed). testFieldNameOk :: Property testFieldNameOk = forAll arbitrary $ \k1 -> forAll arbitrary $ \k2 -> fieldName (s1 (S (Field k1) (Field k2))) == s1FieldName where s1FieldName = "field1" -- | Test the fieldName function (should fail). testFieldNameFail :: Property testFieldNameFail = expectFailure $ property $ fieldName (s1 sampleS) == s1FieldName where sampleS = S (Field 0) (Field 0) s1FieldName = "Field" -- | Test showing a field of a struct. testShowField :: Property testShowField = forAll arbitrary $ \k -> show (s1 (S (Field k) (Field 0))) == ("field1:" ++ show k) -- | Test showing a struct. testShowStruct :: Property testShowStruct = forAll arbitrary $ \k1 -> forAll arbitrary $ \k2 -> show (S (Field k1) (Field k2)) == "" -- | Test showing a struct. testUpdateStruct :: Property testUpdateStruct = forAll arbitrary $ \k1 -> forAll arbitrary $ \k2 -> let f :: Field "field1" Int8 f = Field k2 v :: Value Int8 v = Value Int8 f in unField (s1 (updateField (S (Field k1) (Field 0)) v)) == k2 where unField (Field x) = x -- | Test showing a struct. testUpdateStructFail :: Property testUpdateStructFail = expectFailure $ forAll arbitrary $ \k1 -> forAll arbitrary $ \k3 -> let f :: Field "field" Int8 f = Field k3 v :: Value Int8 v = Value Int8 f in unField (s3 (updateField (S3 (Field k1)) v)) == k3 where unField (Field x) = x -- | Test the accessorName of a field of a struct (should succeed). testAccessorNameOk :: Property testAccessorNameOk = property $ accessorName s1 == s1FieldName where s1FieldName = "field1" -- | Test the accessorName of a field of a struct (should fail). testAccessorNameFail :: Property testAccessorNameFail = expectFailure $ property $ accessorName s1 == s1FieldName where s1FieldName = "Field1" -- | Test the typeName of a struct (should succeed). testTypeNameOk :: Property testTypeNameOk = property $ typeName sampleS == s1TypeName where sampleS :: S sampleS = S (Field 0) (Field 0) s1TypeName :: String s1TypeName = "S" -- | Test the typeName of a struct (should fail). testTypeNameFail :: Property testTypeNameFail = expectFailure $ property $ typeName sampleS == s1TypeName where sampleS :: S sampleS = S (Field 0) (Field 0) s1TypeName :: String s1TypeName = "s" -- | Auxiliary struct defined for testing purposes. data S = S { s1 :: Field "field1" Int8, s2 :: Field "field2" Word8 } instance Struct S where typeName _ = "S" toValues s = [ Value Int8 (s1 s), Value Word8 (s2 s) ] updateField s (Value fieldTy (field :: Field fieldName a)) | Just Refl <- sameSymbol (Proxy @"field1") (Proxy @fieldName) , Just Refl <- testEquality Int8 fieldTy = s { s1 = field } | Just Refl <- sameSymbol (Proxy @"field2") (Proxy @fieldName) , Just Refl <- testEquality Word8 fieldTy = s { s2 = field } | otherwise = error $ "Unexpected field: " P.++ show field instance Typed S where typeOf = Struct (S (Field 0) (Field 0)) -- | Auxiliary struct defined for testing purposes. data S3 = S3 { s3 :: Field "field" Int8 } instance Struct S3 where typeName _ = "S3" toValues s = [ Value Int8 (s3 s) ] instance Typed S3 where typeOf = Struct (S3 (Field 0)) copilot-core-4.3/tests/Test/Copilot/Core/Type/0000755000000000000000000000000014762717257017472 5ustar0000000000000000copilot-core-4.3/tests/Test/Copilot/Core/Type/Array.hs0000644000000000000000000001436414762717257021114 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Test copilot-core:Copilot.Core.Type.Array. module Test.Copilot.Core.Type.Array where -- External imports import Data.Int (Int64) import Data.Proxy (Proxy (..)) import GHC.TypeNats (KnownNat, natVal) import Test.Framework (Test, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck (Gen, Property, arbitrary, chooseInt, expectFailure, forAll, getNegative, getNonNegative, oneof, property, vector, vectorOf) -- Internal imports: library modules being tested import Copilot.Core.Type.Array (Array, array, arrayElems, arrayUpdate) -- | All unit tests for copilot-core:Copilot.Core.Array. tests :: Test.Framework.Test tests = testGroup "Copilot.Core.Type.Array" [ testProperty "arrayElems . array (identity; 0)" (testArrayElemsLeft (Proxy :: Proxy 0)) , testProperty "arrayElems . array (identity; 5)" (testArrayElemsLeft (Proxy :: Proxy 5)) , testProperty "arrayElems . array (identity; 200)" (testArrayElemsLeft (Proxy :: Proxy 200)) , testProperty "array of incorrect length" testArrayElemsFail , testProperty "Show for arrays" testShowArray , testProperty "arrayElems (arrayUpdate x i v) !! i == v" (testArrayUpdateElem (Proxy :: Proxy 5)) , testProperty "arrayUpdate x i ((arrayElems x) !! i) == x" (testArrayUpdateElems (Proxy :: Proxy 5)) , testProperty "arrayUpdate fails if out of range of array" (testArrayUpdateWrong (Proxy :: Proxy 5)) , testProperty "array fails length is wrong" (testArrayMakeWrongLength (Proxy :: Proxy 5)) ] -- * Individual tests -- | Test that building an array from a list and extracting the elements with -- the function 'arrayElems' will result in the same list. testArrayElemsLeft :: forall n . KnownNat n => Proxy n -> Property testArrayElemsLeft len = forAll xsInt64 $ \ls -> let array' :: Array n Int64 array' = array ls in arrayElems array' == ls where -- Generator for lists of Int64 of known length. xsInt64 :: Gen [Int64] xsInt64 = vectorOf (fromIntegral (natVal len)) arbitrary -- | Test that arrays cannot be properly evaluated if their length does not -- match their type. testArrayElemsFail :: Property testArrayElemsFail = expectFailure $ forAll (vector 3) $ \l -> let v = array l :: Array 4 Int64 in arrayElems v == l -- | Test show for arrays. testShowArray :: Property testShowArray = forAll (vector 3) $ \l -> property $ show (array l :: Array 3 Int64) == show (l :: [Int64]) -- | Test that updating an array updates the element appropriately (if we -- project that element we get the value we put in). testArrayUpdateElem :: forall n . KnownNat n => Proxy n -> Property testArrayUpdateElem len = forAll xsInt64 $ \ls -> forAll position $ \p -> forAll xInt64 $ \v -> let -- Original array array' :: Array n Int64 array' = array ls -- Updated array array'' :: Array n Int64 array'' = arrayUpdate array' p v in arrayElems array'' !! p == v where -- Generator for lists of Int64 of known length. xsInt64 :: Gen [Int64] xsInt64 = vectorOf (fromIntegral (natVal len)) arbitrary -- Generator for element of type Int64. xInt64 :: Gen Int64 xInt64 = arbitrary -- Generator for positions within the list. position :: Gen Int position = chooseInt (0, fromIntegral (natVal len) - 1) -- | Test that updating an array updates the element appropriately (if we -- project that element we get the value we put in). testArrayUpdateWrong :: forall n . KnownNat n => Proxy n -> Property testArrayUpdateWrong len = expectFailure $ forAll xsInt64 $ \ls -> forAll position $ \p -> forAll xInt64 $ \v -> let -- Original array array' :: Array n Int64 array' = array ls -- Updated array array'' :: Array n Int64 array'' = arrayUpdate array' (p + 10) v in arrayElems array'' !! p == v where -- Generator for lists of Int64 of known length. xsInt64 :: Gen [Int64] xsInt64 = vectorOf (fromIntegral (natVal len)) arbitrary -- Generator for element of type Int64. xInt64 :: Gen Int64 xInt64 = arbitrary -- Generator for positions within the list. position :: Gen Int position = oneof [ (fromIntegral (natVal len) +) . getNonNegative <$> arbitrary , getNegative <$> arbitrary ] -- | Test that making an array of a specific length fails if the list of -- elements supplied doesn't have the same length. testArrayMakeWrongLength :: forall n . KnownNat n => Proxy n -> Property testArrayMakeWrongLength len = expectFailure $ forAll wrongLength $ \length -> forAll (xsInt64 length) $ \ls -> let array' :: Array n Int64 array' = array ls in arrayElems array' == ls where xsInt64 length = vectorOf length arbitrary expectedLength = fromIntegral (natVal len) wrongLength = (expectedLength +) . getNonNegative <$> arbitrary -- | Test that updating an array updates the element appropriately (if we -- project that element we get the value we put in). testArrayUpdateElems :: forall n . KnownNat n => Proxy n -> Property testArrayUpdateElems len = forAll xsInt64 $ \ls -> forAll position $ \p -> forAll xInt64 $ \v -> let -- Original array array' :: Array n Int64 array' = array ls -- Updated array e :: Int64 e = arrayElems array' !! p array'' :: Array n Int64 array'' = arrayUpdate array' p e in arrayElems array'' == ls where -- Generator for lists of Int64 of known length. xsInt64 :: Gen [Int64] xsInt64 = vectorOf (fromIntegral (natVal len)) arbitrary -- Generator for element of type Int64. xInt64 :: Gen Int64 xInt64 = arbitrary -- Generator for positions within the list. position :: Gen Int position = chooseInt (0, fromIntegral (natVal len) - 1) copilot-core-4.3/src/0000755000000000000000000000000014762717257012756 5ustar0000000000000000copilot-core-4.3/src/Copilot/0000755000000000000000000000000014762717257014367 5ustar0000000000000000copilot-core-4.3/src/Copilot/Core.hs0000644000000000000000000000240514762717257015614 0ustar0000000000000000{-# LANGUAGE Safe #-} -- | -- Description: Intermediate representation for Copilot specifications. -- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. -- -- The following articles might also be useful: -- -- * Carette, Jacques and Kiselyov, Oleg and Shan, Chung-chieh, -- \"/Finally tagless, partially evaluated: Tagless staged/ -- /interpreters for simpler typed languages/\", -- Journal of Functional Programming vol. 19, p. 509-543, 2009. -- -- * Guillemette, Louis-Julien and Monnier, Stefan, -- \"/Type-Safe Code Transformations in Haskell/\", -- Electronic Notes in Theoretical Computer Science vol. 174, p. 23-39, 2007. -- -- For examples of how to traverse a Copilot specification see -- the source code of the interpreter (@copilot-interpreter@) -- and the pretty-printer (@copilot-prettyprinter@). module Copilot.Core ( module Copilot.Core.Expr , module Copilot.Core.Operators , module Copilot.Core.Spec , module Copilot.Core.Type , module Copilot.Core.Type.Array , module Data.Int , module Data.Word ) where -- External imports import Data.Int import Data.Word -- Internal imports import Copilot.Core.Expr import Copilot.Core.Operators import Copilot.Core.Spec import Copilot.Core.Type import Copilot.Core.Type.Array copilot-core-4.3/src/Copilot/Core/0000755000000000000000000000000014762717257015257 5ustar0000000000000000copilot-core-4.3/src/Copilot/Core/Operators.hs0000644000000000000000000000750314762717257017576 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE Safe #-} -- | -- Description: Internal representation of Copilot operators. -- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. module Copilot.Core.Operators ( Op1 (..) , Op2 (..) , Op3 (..) ) where -- External imports import Data.Bits (Bits) import Data.Typeable (Typeable) import Data.Word (Word32) import GHC.TypeLits (KnownSymbol) -- Internal imports import Copilot.Core.Type (Field (..), Type (..)) import Copilot.Core.Type.Array (Array) -- | Unary operators. data Op1 a b where -- Boolean operators. Not :: Op1 Bool Bool -- Numeric operators. Abs :: Num a => Type a -> Op1 a a Sign :: Num a => Type a -> Op1 a a -- Fractional operators. Recip :: Fractional a => Type a -> Op1 a a -- Floating operators. Exp :: Floating a => Type a -> Op1 a a Sqrt :: Floating a => Type a -> Op1 a a Log :: Floating a => Type a -> Op1 a a Sin :: Floating a => Type a -> Op1 a a Tan :: Floating a => Type a -> Op1 a a Cos :: Floating a => Type a -> Op1 a a Asin :: Floating a => Type a -> Op1 a a Atan :: Floating a => Type a -> Op1 a a Acos :: Floating a => Type a -> Op1 a a Sinh :: Floating a => Type a -> Op1 a a Tanh :: Floating a => Type a -> Op1 a a Cosh :: Floating a => Type a -> Op1 a a Asinh :: Floating a => Type a -> Op1 a a Atanh :: Floating a => Type a -> Op1 a a Acosh :: Floating a => Type a -> Op1 a a -- RealFrac operators Ceiling :: RealFrac a => Type a -> Op1 a a Floor :: RealFrac a => Type a -> Op1 a a -- Bitwise operators. BwNot :: Bits a => Type a -> Op1 a a -- Casting operator. Cast :: (Integral a, Num b) => Type a -> Type b -> Op1 a b -- ^ Casting operator. -- Struct operator. GetField :: KnownSymbol s => Type a -> Type b -> (a -> Field s b) -> Op1 a b -- ^ Projection of a struct field. -- | Binary operators. data Op2 a b c where -- Boolean operators. And :: Op2 Bool Bool Bool Or :: Op2 Bool Bool Bool -- Numeric operators. Add :: Num a => Type a -> Op2 a a a Sub :: Num a => Type a -> Op2 a a a Mul :: Num a => Type a -> Op2 a a a -- Integral operators. Mod :: Integral a => Type a -> Op2 a a a Div :: Integral a => Type a -> Op2 a a a -- Fractional operators. Fdiv :: Fractional a => Type a -> Op2 a a a -- Floating operators. Pow :: Floating a => Type a -> Op2 a a a Logb :: Floating a => Type a -> Op2 a a a -- RealFloat operators. Atan2 :: RealFloat a => Type a -> Op2 a a a -- Equality operators. Eq :: Eq a => Type a -> Op2 a a Bool Ne :: Eq a => Type a -> Op2 a a Bool -- Relational operators. Le :: Ord a => Type a -> Op2 a a Bool Ge :: Ord a => Type a -> Op2 a a Bool Lt :: Ord a => Type a -> Op2 a a Bool Gt :: Ord a => Type a -> Op2 a a Bool -- Bitwise operators. BwAnd :: Bits a => Type a -> Op2 a a a BwOr :: Bits a => Type a -> Op2 a a a BwXor :: Bits a => Type a -> Op2 a a a BwShiftL :: (Bits a, Integral b) => Type a -> Type b -> Op2 a b a BwShiftR :: (Bits a, Integral b) => Type a -> Type b -> Op2 a b a -- Array operator. Index :: Type (Array n t) -> Op2 (Array n t) Word32 t -- ^ Array access/projection of an array element. -- Struct operator. UpdateField :: (Typeable b, KnownSymbol s, Show b) => Type a -> Type b -> (a -> Field s b) -> Op2 a b a -- ^ Update a field of a struct. -- | Ternary operators. data Op3 a b c d where -- Conditional operator. Mux :: Type a -> Op3 Bool a a a -- Array operator. UpdateArray :: Type (Array n t) -> Op3 (Array n t) Word32 t (Array n t) -- ^ Update an element of an array. copilot-core-4.3/src/Copilot/Core/Type.hs0000644000000000000000000004127414762717257016544 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Description: Typing for Core. -- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. -- -- All expressions and streams in Core are accompanied by a representation of -- the types of the underlying expressions used or carried by the streams. -- This information is needed by the compiler to generate code, since it must -- initialize variables and equivalent representations for those types in -- the target languages. module Copilot.Core.Type ( Type (..) , Typed (..) , typeOfDefault , UType (..) , SimpleType (..) , typeSize , typeLength , Value (..) , toValues , toValuesDefault , Field (..) , typeName , typeNameDefault , Struct , fieldName , accessorName , updateField , updateFieldDefault ) where -- External imports import Data.Char (isLower, isUpper, toLower) import Data.Coerce (coerce) import Data.Int (Int16, Int32, Int64, Int8) import Data.List (intercalate) import Data.Proxy (Proxy (..)) import Data.Type.Equality as DE import Data.Typeable (Typeable, eqT, typeRep) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Generics (Datatype (..), D1, Generic (..), K1 (..), M1 (..), U1 (..), (:*:) (..)) import GHC.TypeLits (KnownNat, KnownSymbol, Symbol, natVal, sameNat, sameSymbol, symbolVal) -- Internal imports import Copilot.Core.Type.Array (Array) -- | The value of that is a product or struct, defined as a constructor with -- several fields. class Struct a where -- | Returns the name of struct in the target language. typeName :: a -> String -- | Transforms all the struct's fields into a list of values. toValues :: a -> [Value a] -- | Update the value of a struct field. This is only used by the Copilot -- interpreter. -- -- If you do not plan to use the interpreter, you can omit an implementation -- of this method. If you do so, it is recommended that you derive a 'Generic' -- instance for the struct data type. This is because in a future release, the -- default implementation of 'updateField' (which will be picked if there is -- not a manually written implementation) will be changed to require a -- 'Generic' instance. -- -- In order to implement 'updateField', pick one of the following approaches: -- -- * Derive a 'Generic' instance for the struct data type and then define -- @'updateField' = 'updateFieldDefault'@ in the 'Struct' instance. -- -- * Manually implement 'updateField' by doing the following for each 'Field' -- in a struct: -- -- 1. Check that the name of the 'Field' matches the name of the supplied -- 'Value' (using 'GHC.TypeLits.sameSymbol'). -- -- 2. Check that the type of the 'Field' matches the 'Type' of the supplied -- 'Value' (using 'DE.testEquality'). -- -- 3. If both (1) and (2) succeed, update the corresponding struct field -- using a record update. -- -- For a complete end-to-end example that demonstrates how to manually -- implement 'updateField' and use it in the Copilot interpreter, see the -- @examples/StructsUpdateField.hs@ example in the @copilot@ library. updateField :: a -> Value t -> a updateField = error $ unlines [ "Field updates not supported for this type." , "(Perhaps you need to implement 'updateField' for a 'Struct' instance?)" ] -- | The field of a struct, together with a representation of its type. data Value a = forall s t . (Typeable t, KnownSymbol s, Show t) => Value (Type t) (Field s t) -- | A field in a struct. The name of the field is a literal at the type -- level. data Field (s :: Symbol) t = Field t -- | Extract the name of a field. fieldName :: forall s t . KnownSymbol s => Field s t -> String fieldName _ = symbolVal (Proxy :: Proxy s) -- | Extract the name of an accessor (a function that returns a field of a -- struct). accessorName :: forall a s t . (Struct a, KnownSymbol s) => (a -> Field s t) -> String accessorName _ = symbolVal (Proxy :: Proxy s) instance (KnownSymbol s, Show t) => Show (Field s t) where show f@(Field v) = fieldName f ++ ":" ++ show v instance {-# OVERLAPPABLE #-} (Typed t, Struct t) => Show t where show t = "<" ++ fields ++ ">" where fields = intercalate "," $ map showfield (toValues t) showfield (Value _ field) = show field -- | A Type representing the types of expressions or values handled by -- Copilot Core. -- -- Note that both arrays and structs use dependently typed features. In the -- former, the length of the array is part of the type. In the latter, the -- names of the fields are part of the type. data Type :: * -> * where Bool :: Type Bool Int8 :: Type Int8 Int16 :: Type Int16 Int32 :: Type Int32 Int64 :: Type Int64 Word8 :: Type Word8 Word16 :: Type Word16 Word32 :: Type Word32 Word64 :: Type Word64 Float :: Type Float Double :: Type Double Array :: forall n t . ( KnownNat n , Typed t ) => Type t -> Type (Array n t) Struct :: (Typed a, Struct a) => a -> Type a deriving instance Show (Type a) -- | Return the length of an array from its type typeLength :: forall n t . KnownNat n => Type (Array n t) -> Int typeLength _ = fromIntegral $ natVal (Proxy :: Proxy n) -- | Return the total (nested) size of an array from its type typeSize :: forall n t . KnownNat n => Type (Array n t) -> Int typeSize ty@(Array ty'@(Array _)) = typeLength ty * typeSize ty' typeSize ty@(Array _ ) = typeLength ty instance TestEquality Type where testEquality Bool Bool = Just DE.Refl testEquality Int8 Int8 = Just DE.Refl testEquality Int16 Int16 = Just DE.Refl testEquality Int32 Int32 = Just DE.Refl testEquality Int64 Int64 = Just DE.Refl testEquality Word8 Word8 = Just DE.Refl testEquality Word16 Word16 = Just DE.Refl testEquality Word32 Word32 = Just DE.Refl testEquality Word64 Word64 = Just DE.Refl testEquality Float Float = Just DE.Refl testEquality Double Double = Just DE.Refl testEquality (Array t1) (Array t2) = testArrayEquality t1 t2 where testArrayEquality :: forall n1 a1 n2 a2. (KnownNat n1, KnownNat n2) => Type a1 -> Type a2 -> Maybe (Array n1 a1 :~: Array n2 a2) testArrayEquality ty1 ty2 | Just DE.Refl <- sameNat (Proxy :: Proxy n1) (Proxy :: Proxy n2) , Just DE.Refl <- testEquality ty1 ty2 = Just DE.Refl | otherwise = Nothing testEquality (Struct _) (Struct _) = eqT testEquality _ _ = Nothing -- | A simple, monomorphic representation of types that facilitates putting -- variables in heterogeneous lists and environments in spite of their types -- being different. data SimpleType where SBool :: SimpleType SInt8 :: SimpleType SInt16 :: SimpleType SInt32 :: SimpleType SInt64 :: SimpleType SWord8 :: SimpleType SWord16 :: SimpleType SWord32 :: SimpleType SWord64 :: SimpleType SFloat :: SimpleType SDouble :: SimpleType SArray :: Type t -> SimpleType SStruct :: SimpleType -- | Type equality, used to help type inference. -- This instance is necessary, otherwise the type of SArray can't be inferred. instance Eq SimpleType where SBool == SBool = True SInt8 == SInt8 = True SInt16 == SInt16 = True SInt32 == SInt32 = True SInt64 == SInt64 = True SWord8 == SWord8 = True SWord16 == SWord16 = True SWord32 == SWord32 = True SWord64 == SWord64 = True SFloat == SFloat = True SDouble == SDouble = True (SArray t1) == (SArray t2) | Just DE.Refl <- testEquality t1 t2 = True | otherwise = False SStruct == SStruct = True _ == _ = False -- | A typed expression, from which we can obtain the two type representations -- used by Copilot: 'Type' and 'SimpleType'. class (Show a, Typeable a) => Typed a where typeOf :: Type a simpleType :: Type a -> SimpleType simpleType _ = SStruct instance Typed Bool where typeOf = Bool simpleType _ = SBool instance Typed Int8 where typeOf = Int8 simpleType _ = SInt8 instance Typed Int16 where typeOf = Int16 simpleType _ = SInt16 instance Typed Int32 where typeOf = Int32 simpleType _ = SInt32 instance Typed Int64 where typeOf = Int64 simpleType _ = SInt64 instance Typed Word8 where typeOf = Word8 simpleType _ = SWord8 instance Typed Word16 where typeOf = Word16 simpleType _ = SWord16 instance Typed Word32 where typeOf = Word32 simpleType _ = SWord32 instance Typed Word64 where typeOf = Word64 simpleType _ = SWord64 instance Typed Float where typeOf = Float simpleType _ = SFloat instance Typed Double where typeOf = Double simpleType _ = SDouble instance (Typeable t, Typed t, KnownNat n) => Typed (Array n t) where typeOf = Array typeOf simpleType (Array t) = SArray t -- | A untyped type (no phantom type). data UType = forall a . Typeable a => UType { uTypeType :: Type a } {-# DEPRECATED uTypeType "This field is deprecated in Copilot 4.1. Use pattern matching instead." #-} instance Eq UType where UType ty1 == UType ty2 = typeRep ty1 == typeRep ty2 -- * GHC.Generics-based defaults -- | A default implementation of 'typeName' that leverages 'Generic'. In order -- to use this, make sure you derive a 'Generic' instance for your data type and -- then define @'typeName' = 'typeNameDefault'@ in its 'Struct' instance. -- -- This generates a struct name that consists of the name of the original -- Haskell data type, but converted to snake_case. typeNameDefault :: (Generic a, GDatatype (Rep a)) => a -> String typeNameDefault = convert . gTypeName . from where convert :: String -> String convert = convert' True True convert' :: Bool -- ^ Is this the first letter -> Bool -- ^ Was the previous letter capital -> String -- ^ Remainder of the string -> String convert' _ _ [] = [] convert' _ v [x] | v && isUpper x = toLower x : [] | isUpper x = '_' : toLower x : [] | otherwise = x : [] convert' b v (x1:x2:xs) | not b && isUpper x1 && (isLower x2 || not v) = '_' : toLower x1 : convert' False (isUpper x1) (x2:xs) | otherwise = toLower x1 : convert' False (isUpper x1) (x2:xs) -- | A default implementation of 'toValues' that leverages 'Generic'. In order -- to use this, make sure you derive a 'Generic' instance for your data type and -- then define @'toValues' = 'toValuesDefault'@ in its 'Struct' instance. toValuesDefault :: (Generic a, GStruct (Rep a)) => a -> [Value a] toValuesDefault x = coerce $ gToValues $ from x -- | A default implementation of 'updateField' that leverages 'Generic'. In -- order to use this, make sure you derive a 'Generic' instance for your data -- type and then define @'updateField' = 'updateFieldDefault'@ in its 'Struct' -- instance. updateFieldDefault :: (Generic a, GStruct (Rep a)) => a -> Value t -> a updateFieldDefault a v@(Value _ field) | updated = to a' | otherwise = error $ "Unexpected field: " ++ show field where (a', updated) = gUpdateField (from a) v -- | A default implementation of 'typeOf' that leverages 'Generic'. In order to -- use this, make sure you derive a 'Generic' instance for your data type and -- then define @'typeOf' = 'typeOfDefault'@ in its 'Typed' instance. typeOfDefault :: forall a. (Typed a, Struct a, Generic a, GTypedStruct (Rep a)) => Type a typeOfDefault = Struct $ to $ gStructPlaceholder @(Rep a) @() -- ** Generic-based classes (not exported) -- | Capture the name of a Haskell data type from its 'Generic' metadata. class GDatatype f where -- | Returns the name of a Haskell data type. (Note that this differs from -- 'typeName', which is expected to return the name of the struct in the -- /target/ language). gTypeName :: f p -> String -- | The only 'GDatatype' instance we need is for 'D1', which describes -- 'Datatype' metadata (@d@). We ignore all other metadata (@_f@). instance Datatype d => GDatatype (D1 d _f) where gTypeName = datatypeName -- | Perform struct-related operations on 'Generic' representation types. class GStruct f where -- | Transforms all the struct representation's fields into a list of values. gToValues :: f p -> [Value (f p)] -- | Update the value of a struct representation's field. This returns two -- things: -- -- 1. @f p@: The struct representation, but with the field updated. -- -- 2. 'Bool': This is 'True' if the field was successfully updated and 'False' -- otherwise. If this returns 'False', it is the responsibility of the -- caller to raise an error. gUpdateField :: f p -> Value t -> (f p, Bool) -- | 'U1' represents a data constructor with no fields. As such, 'gToValues' -- returns an empty list of 'Value's, and 'gUpdateField' does not update -- anything. instance GStruct U1 where gToValues U1 = [] gUpdateField u _ = (u, False) -- | 'M1' is only used to store metadata, which the 'GStruct' class does not -- make use of. As such, this instance discards the metadata and recurses. instance GStruct f => GStruct (M1 _i _c f) where gToValues (M1 x) = coerce (gToValues x) gUpdateField (M1 x) v = (M1 x', updated) where (x', updated) = gUpdateField x v -- | @(':*:')@ represents a data constructor with multiple fields. instance (GStruct f, GStruct g) => GStruct (f :*: g) where -- Recursively compute two lists of Values and append them. gToValues (f :*: g) = coerce (gToValues f) ++ coerce (gToValues g) -- Recursively attempt to update the field in both branches and combine the -- updated branches. We will have successfully updated the field if either -- branch was successfully updated. gUpdateField (f :*: g) v = (f' :*: g', updatedF || updatedG) where (f', updatedF) = gUpdateField f v (g', updatedG) = gUpdateField g v -- | 'K1' represents a single field in a data constructor. This is the base -- case. instance (KnownSymbol name, Typed ty, c ~ Field name ty) => GStruct (K1 _i c) where -- Now that we have the field, return it in a singleton list. gToValues (K1 field) = [Value typeOf field] -- In order to update the field, we check that the field names and types -- match. If they do, return the updated field and declare the update as -- successful. Otherwise, return the old field and declare the update as -- unsuccessful. gUpdateField (K1 oldField) (Value newTy (newField :: Field newName newTy)) = case (sameSymbol pName pNewName, testEquality ty newTy) of (Just Refl, Just Refl) -> (K1 newField, True) _ -> (K1 oldField, False) where pName = Proxy @name pNewName = Proxy @newName ty = typeOf @ty -- | Compute a 'Generic' placeholder value to use for a struct type. class GTypedStruct f where -- | A placeholder value to supply to use in a generic implementation of -- 'typeOf' for a struct type. gStructPlaceholder :: f p -- | 'U1' represents a data constructor with no fields. As such, -- 'gStructPlaceholder' simply returns the data constructor with no other -- information. instance GTypedStruct U1 where gStructPlaceholder = U1 -- | 'M1' is only used to store metadata, which the 'GTypedStruct' class does -- not make use of. As such, this instance recursively computes a placeholder -- value without inspecting the metadata. instance GTypedStruct f => GTypedStruct (M1 _i _c f) where gStructPlaceholder = M1 gStructPlaceholder -- | @(':*:')@ represents a data constructor with multiple fields. As such, -- 'gStructPlaceholder' recursively computes placeholders for each field and -- combines them into the overall data constructor. instance (GTypedStruct f, GTypedStruct g) => GTypedStruct (f :*: g) where gStructPlaceholder = gStructPlaceholder :*: gStructPlaceholder -- | 'K1' represents a single field in a data constructor. This is the base -- case. This instance computes a placeholder value that works for any field of -- any type. instance (c ~ Field name ty) => GTypedStruct (K1 _i c) where -- We use 'undefined' as the actual value for the 'Field' because Copilot -- never inspects the value. gStructPlaceholder = K1 $ Field undefined copilot-core-4.3/src/Copilot/Core/Spec.hs0000644000000000000000000000574514762717257016520 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Safe #-} -- | -- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. -- -- Copilot specifications constitute the main declaration of Copilot modules. -- -- A specification normally contains the association between streams to monitor -- and their handling functions, or streams to observe, or a theorem that must -- be proved. -- -- In order to be executed, high-level Copilot Language Spec must be turned -- into Copilot Core's 'Spec'. This module defines the low-level Copilot Core -- representations for Specs and the main types of element in a spec. module Copilot.Core.Spec ( Stream (..) , Observer (..) , Trigger (..) , Spec (..) , Property (..) , Prop (..) , extractProp ) where -- External imports import Data.Typeable (Typeable) -- Internal imports import Copilot.Core.Expr (Expr, Id, Name, UExpr) import Copilot.Core.Type (Type, Typed) -- | A stream in an infinite succession of values of the same type. -- -- Stream can carry different types of data. Boolean streams play a special -- role: they are used by other parts (e.g., 'Trigger') to detect when the -- properties being monitored are violated. data Stream = forall a . (Typeable a, Typed a) => Stream { streamId :: Id , streamBuffer :: [a] , streamExpr :: Expr a , streamExprType :: Type a } -- | An observer, representing a stream that we observe during interpretation -- at every sample. data Observer = forall a . Typeable a => Observer { observerName :: Name , observerExpr :: Expr a , observerExprType :: Type a } -- | A trigger, representing a function we execute when a boolean stream becomes -- true at a sample. data Trigger = Trigger { triggerName :: Name , triggerGuard :: Expr Bool , triggerArgs :: [UExpr] } -- | A property, representing a boolean stream that is existentially or -- universally quantified over time. data Property = Property { propertyName :: Name , propertyProp :: Prop } -- | A proposition, representing a boolean stream that is existentially or -- universally quantified over time. data Prop = Forall (Expr Bool) | Exists (Expr Bool) -- | Extract the underlying stream from a quantified proposition. -- -- Think carefully before using this function, as this function will remove the -- quantifier from a proposition. Universally quantified streams usually require -- separate treatment from existentially quantified ones, so carelessly using -- this function to remove quantifiers can result in hard-to-spot soundness -- bugs. extractProp :: Prop -> Expr Bool extractProp (Forall e) = e extractProp (Exists e) = e -- | A Copilot specification is a list of streams, together with monitors on -- these streams implemented as observers, triggers or properties. data Spec = Spec { specStreams :: [Stream] , specObservers :: [Observer] , specTriggers :: [Trigger] , specProperties :: [Property] } copilot-core-4.3/src/Copilot/Core/Expr.hs0000644000000000000000000000413514762717257016534 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Safe #-} -- | -- Description: Internal representation of Copilot stream expressions. -- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. module Copilot.Core.Expr ( Id , Name , Expr (..) , UExpr (..) , DropIdx ) where -- External imports import Data.Typeable (Typeable) import Data.Word (Word32) -- Internal imports import Copilot.Core.Operators (Op1, Op2, Op3) import Copilot.Core.Type (Type) -- | A stream identifier. type Id = Int -- | A name of a trigger, an external variable, or an external function. type Name = String -- | An index for the drop operator. type DropIdx = Word32 -- | Internal representation of Copilot stream expressions. -- -- The Core representation mimics the high-level Copilot stream, but the Core -- representation contains information about the types of elements in the -- stream. data Expr a where Const :: Typeable a => Type a -> a -> Expr a Drop :: Typeable a => Type a -> DropIdx -> Id -> Expr a Local :: Typeable a => Type a -> Type b -> Name -> Expr a -> Expr b -> Expr b Var :: Typeable a => Type a -> Name -> Expr a ExternVar :: Typeable a => Type a -> Name -> Maybe [a] -> Expr a Op1 :: Typeable a => Op1 a b -> Expr a -> Expr b Op2 :: (Typeable a, Typeable b) => Op2 a b c -> Expr a -> Expr b -> Expr c Op3 :: (Typeable a, Typeable b, Typeable c) => Op3 a b c d -> Expr a -> Expr b -> Expr c -> Expr d Label :: Typeable a => Type a -> String -> Expr a -> Expr a -- | A untyped expression that carries the information about the type of the -- expression as a value, as opposed to exposing it at type level (using an -- existential). data UExpr = forall a . Typeable a => UExpr { uExprType :: Type a , uExprExpr :: Expr a } {-# DEPRECATED uExprType, uExprExpr "These fields are deprecated in Copilot 4.2. Use pattern matching instead." #-} copilot-core-4.3/src/Copilot/Core/Type/0000755000000000000000000000000014762717257016200 5ustar0000000000000000copilot-core-4.3/src/Copilot/Core/Type/Array.hs0000644000000000000000000000403314762717257017612 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | -- Copyright: (c) 2011 National Institute of Aerospace / Galois, Inc. -- -- Implementation of an array that uses type literals to store length. No -- explicit indexing is used for the input data. Supports arbitrary nesting of -- arrays. module Copilot.Core.Type.Array ( Array , array , arrayElems , arrayUpdate ) where -- External imports import Data.Proxy (Proxy (..)) import GHC.TypeLits (KnownNat, Nat, natVal, type(-)) -- | Implementation of an array that uses type literals to store length. data Array (n :: Nat) t where Array :: [t] -> Array n t instance Show t => Show (Array n t) where show (Array xs) = show xs -- | Smart array constructor that only type checks if the length of the given -- list matches the length of the array at type level. array :: forall n t. KnownNat n => [t] -> Array n t array xs | datalen == typelen = Array xs | otherwise = error errmsg where datalen = length xs typelen = fromIntegral $ natVal (Proxy :: Proxy n) errmsg = "Length of data (" ++ show datalen ++ ") does not match length of type (" ++ show typelen ++ ")." -- | Return the elements of an array. arrayElems :: Array n a -> [a] arrayElems (Array xs) = xs -- | Update element of array to given element. -- -- PRE: the second argument denotes a valid index in the array. arrayUpdate :: Array n a -> Int -> a -> Array n a arrayUpdate (Array []) _ _ = error errMsg where errMsg = "copilot-core: arrayUpdate: Attempt to update empty array" arrayUpdate (Array (x:xs)) 0 y = Array (y:xs) arrayUpdate (Array (x:xs)) n y = arrayAppend x (arrayUpdate (Array xs) (n - 1) y) where -- | Append to an array while preserving length information at the type -- level. arrayAppend :: a -> Array (n - 1) a -> Array n a arrayAppend x (Array xs) = Array (x:xs)