diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,31 @@ +# Revision history for ogma-extra + +## [1.0.6] - 2022-11-21 + +* Version bump 1.0.6 (#64). +* Update license in cabal file to OtherLicense (#62). + +## [1.0.5] - 2022-09-21 + +* Version bump 1.0.5 (#60). + +## [1.0.4] - 2022-07-21 + +* Version bump 1.0.4 (#53). + +## [1.0.3] - 2022-05-21 + +* Version bump 1.0.3 (#49). + +## [1.0.2] - 2022-03-21 + +* Version bump 1.0.2 (#43). + +## [1.0.1] - 2022-01-21 + +* Version bump 1.0.1 (#39). +* Adjust indentation of ogma-extra:Data.ByteString.Extra.safeReadFile (#38). + +## [1.0.0] - 2021-11-22 + +* Initial release. diff --git a/LICENSE.pdf b/LICENSE.pdf new file mode 100644 Binary files /dev/null and b/LICENSE.pdf differ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ogma-extra.cabal b/ogma-extra.cabal new file mode 100644 --- /dev/null +++ b/ogma-extra.cabal @@ -0,0 +1,101 @@ +-- Copyright 2020 United States Government as represented by the Administrator +-- of the National Aeronautics and Space Administration. All Rights Reserved. +-- +-- Disclaimers +-- +-- No Warranty: THE SUBJECT SOFTWARE IS PROVIDED "AS IS" WITHOUT ANY WARRANTY +-- OF ANY KIND, EITHER EXPRESSED, IMPLIED, OR STATUTORY, INCLUDING, BUT NOT +-- LIMITED TO, ANY WARRANTY THAT THE SUBJECT SOFTWARE WILL CONFORM TO +-- SPECIFICATIONS, ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A +-- PARTICULAR PURPOSE, OR FREEDOM FROM INFRINGEMENT, ANY WARRANTY THAT THE +-- SUBJECT SOFTWARE WILL BE ERROR FREE, OR ANY WARRANTY THAT DOCUMENTATION, IF +-- PROVIDED, WILL CONFORM TO THE SUBJECT SOFTWARE. THIS AGREEMENT DOES NOT, IN +-- ANY MANNER, CONSTITUTE AN ENDORSEMENT BY GOVERNMENT AGENCY OR ANY PRIOR +-- RECIPIENT OF ANY RESULTS, RESULTING DESIGNS, HARDWARE, SOFTWARE PRODUCTS OR +-- ANY OTHER APPLICATIONS RESULTING FROM USE OF THE SUBJECT SOFTWARE. FURTHER, +-- GOVERNMENT AGENCY DISCLAIMS ALL WARRANTIES AND LIABILITIES REGARDING +-- THIRD-PARTY SOFTWARE, IF PRESENT IN THE ORIGINAL SOFTWARE, AND DISTRIBUTES +-- IT "AS IS."
 +-- +-- Waiver and Indemnity: RECIPIENT AGREES TO WAIVE ANY AND ALL CLAIMS AGAINST +-- THE UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS +-- ANY PRIOR RECIPIENT. IF RECIPIENT'S USE OF THE SUBJECT SOFTWARE RESULTS IN +-- ANY LIABILITIES, DEMANDS, DAMAGES, EXPENSES OR LOSSES ARISING FROM SUCH USE, +-- INCLUDING ANY DAMAGES FROM PRODUCTS BASED ON, OR RESULTING FROM, RECIPIENT'S +-- USE OF THE SUBJECT SOFTWARE, RECIPIENT SHALL INDEMNIFY AND HOLD HARMLESS THE +-- UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS ANY +-- PRIOR RECIPIENT, TO THE EXTENT PERMITTED BY LAW. RECIPIENT'S SOLE REMEDY +-- FOR ANY SUCH MATTER SHALL BE THE IMMEDIATE, UNILATERAL TERMINATION OF THIS +-- AGREEMENT. + +cabal-version: 2.0 +build-type: Simple + +name: ogma-extra +version: 1.0.6 +homepage: http://nasa.gov +license: OtherLicense +license-file: LICENSE.pdf +author: Ivan Perez, Alwyn Goodloe +maintainer: ivan.perezdominguez@nasa.gov +category: Aerospace +extra-source-files: CHANGELOG.md + +synopsis: Ogma: Helper tool to interoperate between Copilot and other languages. + +description: Ogma is a tool to facilitate the integration of safe runtime monitors into + other systems. Ogma extends + , a high-level runtime + verification framework that generates hard real-time C99 code. + . + This package implements internal extensions to existing libraries + and modules that are used in several ogma packages and their + testing facilities. + +library + + exposed-modules: + Data.ByteString.Extra + Data.List.Extra + Data.String.Extra + System.Directory.Extra + + build-depends: + base >= 4.11.0.0 && < 5 + , bytestring + , Cabal + , directory + , filepath + + hs-source-dirs: + src + + default-language: + Haskell2010 + + ghc-options: + -Wall + +test-suite unit-tests + type: + exitcode-stdio-1.0 + + main-is: + Main.hs + + build-depends: + base + , QuickCheck + , test-framework + , test-framework-quickcheck2 + + , ogma-extra + + hs-source-dirs: + tests + + default-language: + Haskell2010 + + ghc-options: + -Wall diff --git a/src/Data/ByteString/Extra.hs b/src/Data/ByteString/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Extra.hs @@ -0,0 +1,57 @@ +-- Copyright 2020 United States Government as represented by the Administrator +-- of the National Aeronautics and Space Administration. All Rights Reserved. +-- +-- Disclaimers +-- +-- No Warranty: THE SUBJECT SOFTWARE IS PROVIDED "AS IS" WITHOUT ANY WARRANTY +-- OF ANY KIND, EITHER EXPRESSED, IMPLIED, OR STATUTORY, INCLUDING, BUT NOT +-- LIMITED TO, ANY WARRANTY THAT THE SUBJECT SOFTWARE WILL CONFORM TO +-- SPECIFICATIONS, ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A +-- PARTICULAR PURPOSE, OR FREEDOM FROM INFRINGEMENT, ANY WARRANTY THAT THE +-- SUBJECT SOFTWARE WILL BE ERROR FREE, OR ANY WARRANTY THAT DOCUMENTATION, IF +-- PROVIDED, WILL CONFORM TO THE SUBJECT SOFTWARE. THIS AGREEMENT DOES NOT, IN +-- ANY MANNER, CONSTITUTE AN ENDORSEMENT BY GOVERNMENT AGENCY OR ANY PRIOR +-- RECIPIENT OF ANY RESULTS, RESULTING DESIGNS, HARDWARE, SOFTWARE PRODUCTS OR +-- ANY OTHER APPLICATIONS RESULTING FROM USE OF THE SUBJECT SOFTWARE. FURTHER, +-- GOVERNMENT AGENCY DISCLAIMS ALL WARRANTIES AND LIABILITIES REGARDING +-- THIRD-PARTY SOFTWARE, IF PRESENT IN THE ORIGINAL SOFTWARE, AND DISTRIBUTES +-- IT "AS IS." +-- +-- Waiver and Indemnity: RECIPIENT AGREES TO WAIVE ANY AND ALL CLAIMS AGAINST +-- THE UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS +-- ANY PRIOR RECIPIENT. IF RECIPIENT'S USE OF THE SUBJECT SOFTWARE RESULTS IN +-- ANY LIABILITIES, DEMANDS, DAMAGES, EXPENSES OR LOSSES ARISING FROM SUCH USE, +-- INCLUDING ANY DAMAGES FROM PRODUCTS BASED ON, OR RESULTING FROM, RECIPIENT'S +-- USE OF THE SUBJECT SOFTWARE, RECIPIENT SHALL INDEMNIFY AND HOLD HARMLESS THE +-- UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS ANY +-- PRIOR RECIPIENT, TO THE EXTENT PERMITTED BY LAW. RECIPIENT'S SOLE REMEDY +-- FOR ANY SUCH MATTER SHALL BE THE IMMEDIATE, UNILATERAL TERMINATION OF THIS +-- AGREEMENT. +-- +-- | Auxiliary functions for working with values of type 'ByteString'. +module Data.ByteString.Extra where + +import Control.Exception ( catch ) +import qualified Data.ByteString.Lazy as B +import System.IO.Error ( isDoesNotExistError ) + +-- * Safe I/O + +-- | Safely read a file into a lazy 'ByteString', returning a 'Left' error +-- message if the file cannot be opened. +safeReadFile :: FilePath -> IO (Either String B.ByteString) +safeReadFile fp = + catch (return <$> B.readFile fp) $ \e -> + if isDoesNotExistError e + then return $ Left $ strByteStringFileNotFound fp + else return $ Left $ strByteStringCannotOpenFile fp + +-- ** Error messages + +-- | File-not-found message. +strByteStringFileNotFound :: FilePath -> String +strByteStringFileNotFound fp = "File not found: " ++ fp + +-- | Cannot-open-file message. +strByteStringCannotOpenFile :: FilePath -> String +strByteStringCannotOpenFile fp = "Error opening file " ++ fp diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Extra.hs @@ -0,0 +1,47 @@ +-- Copyright 2020 United States Government as represented by the Administrator +-- of the National Aeronautics and Space Administration. All Rights Reserved. +-- +-- Disclaimers +-- +-- No Warranty: THE SUBJECT SOFTWARE IS PROVIDED "AS IS" WITHOUT ANY WARRANTY +-- OF ANY KIND, EITHER EXPRESSED, IMPLIED, OR STATUTORY, INCLUDING, BUT NOT +-- LIMITED TO, ANY WARRANTY THAT THE SUBJECT SOFTWARE WILL CONFORM TO +-- SPECIFICATIONS, ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A +-- PARTICULAR PURPOSE, OR FREEDOM FROM INFRINGEMENT, ANY WARRANTY THAT THE +-- SUBJECT SOFTWARE WILL BE ERROR FREE, OR ANY WARRANTY THAT DOCUMENTATION, IF +-- PROVIDED, WILL CONFORM TO THE SUBJECT SOFTWARE. THIS AGREEMENT DOES NOT, IN +-- ANY MANNER, CONSTITUTE AN ENDORSEMENT BY GOVERNMENT AGENCY OR ANY PRIOR +-- RECIPIENT OF ANY RESULTS, RESULTING DESIGNS, HARDWARE, SOFTWARE PRODUCTS OR +-- ANY OTHER APPLICATIONS RESULTING FROM USE OF THE SUBJECT SOFTWARE. FURTHER, +-- GOVERNMENT AGENCY DISCLAIMS ALL WARRANTIES AND LIABILITIES REGARDING +-- THIRD-PARTY SOFTWARE, IF PRESENT IN THE ORIGINAL SOFTWARE, AND DISTRIBUTES +-- IT "AS IS." +-- +-- Waiver and Indemnity: RECIPIENT AGREES TO WAIVE ANY AND ALL CLAIMS AGAINST +-- THE UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS +-- ANY PRIOR RECIPIENT. IF RECIPIENT'S USE OF THE SUBJECT SOFTWARE RESULTS IN +-- ANY LIABILITIES, DEMANDS, DAMAGES, EXPENSES OR LOSSES ARISING FROM SUCH USE, +-- INCLUDING ANY DAMAGES FROM PRODUCTS BASED ON, OR RESULTING FROM, RECIPIENT'S +-- USE OF THE SUBJECT SOFTWARE, RECIPIENT SHALL INDEMNIFY AND HOLD HARMLESS THE +-- UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS ANY +-- PRIOR RECIPIENT, TO THE EXTENT PERMITTED BY LAW. RECIPIENT'S SOLE REMEDY +-- FOR ANY SUCH MATTER SHALL BE THE IMMEDIATE, UNILATERAL TERMINATION OF THIS +-- AGREEMENT. +-- +-- | Auxiliary functions for working with values of type '[]'. +module Data.List.Extra where + +-- | Safely extract the head of a list. +headEither :: [a] -> Either String a +headEither (a:_) = Right a +headEither [] = Left "Empty list" + +-- | Apply a transformation only to the head of a list. +toHead :: (a -> a) -> [a] -> [a] +toHead f (x:xs) = f x : xs +toHead _ xs = xs + +-- | Apply a transformation only to the tail of a list. +toTail :: (a -> a) -> [a] -> [a] +toTail f (x:xs) = x : fmap f xs +toTail _ xs = xs diff --git a/src/Data/String/Extra.hs b/src/Data/String/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/String/Extra.hs @@ -0,0 +1,101 @@ +-- Copyright 2020 United States Government as represented by the Administrator +-- of the National Aeronautics and Space Administration. All Rights Reserved. +-- +-- Disclaimers +-- +-- No Warranty: THE SUBJECT SOFTWARE IS PROVIDED "AS IS" WITHOUT ANY WARRANTY +-- OF ANY KIND, EITHER EXPRESSED, IMPLIED, OR STATUTORY, INCLUDING, BUT NOT +-- LIMITED TO, ANY WARRANTY THAT THE SUBJECT SOFTWARE WILL CONFORM TO +-- SPECIFICATIONS, ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A +-- PARTICULAR PURPOSE, OR FREEDOM FROM INFRINGEMENT, ANY WARRANTY THAT THE +-- SUBJECT SOFTWARE WILL BE ERROR FREE, OR ANY WARRANTY THAT DOCUMENTATION, IF +-- PROVIDED, WILL CONFORM TO THE SUBJECT SOFTWARE. THIS AGREEMENT DOES NOT, IN +-- ANY MANNER, CONSTITUTE AN ENDORSEMENT BY GOVERNMENT AGENCY OR ANY PRIOR +-- RECIPIENT OF ANY RESULTS, RESULTING DESIGNS, HARDWARE, SOFTWARE PRODUCTS OR +-- ANY OTHER APPLICATIONS RESULTING FROM USE OF THE SUBJECT SOFTWARE. FURTHER, +-- GOVERNMENT AGENCY DISCLAIMS ALL WARRANTIES AND LIABILITIES REGARDING +-- THIRD-PARTY SOFTWARE, IF PRESENT IN THE ORIGINAL SOFTWARE, AND DISTRIBUTES +-- IT "AS IS." +-- +-- Waiver and Indemnity: RECIPIENT AGREES TO WAIVE ANY AND ALL CLAIMS AGAINST +-- THE UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS +-- ANY PRIOR RECIPIENT. IF RECIPIENT'S USE OF THE SUBJECT SOFTWARE RESULTS IN +-- ANY LIABILITIES, DEMANDS, DAMAGES, EXPENSES OR LOSSES ARISING FROM SUCH USE, +-- INCLUDING ANY DAMAGES FROM PRODUCTS BASED ON, OR RESULTING FROM, RECIPIENT'S +-- USE OF THE SUBJECT SOFTWARE, RECIPIENT SHALL INDEMNIFY AND HOLD HARMLESS THE +-- UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS ANY +-- PRIOR RECIPIENT, TO THE EXTENT PERMITTED BY LAW. RECIPIENT'S SOLE REMEDY +-- FOR ANY SUCH MATTER SHALL BE THE IMMEDIATE, UNILATERAL TERMINATION OF THIS +-- AGREEMENT. +-- +-- | Auxiliary functions for working with values of type 'String'. +module Data.String.Extra + ( + -- * Safe I/O + safeReadFile + + -- * String sanitization + , sanitizeLCIdentifier + , sanitizeUCIdentifier + ) + where + +-- External imports +import Control.Exception ( catch ) +import Data.Char ( toLower, toUpper ) +import System.IO.Error ( isDoesNotExistError ) + +-- * Safe I/O + +-- | Safely read a file into a 'String', returning a 'Left' error message if +-- the file cannot be opened. + +-- This function could also be placed in System.IO. However, we decide to +-- include it in this module for symmetry with an analogous function for +-- ByteString, included in Data.ByteString.Extra. +safeReadFile :: FilePath -> IO (Either String String) +safeReadFile fp = + catch (return <$> readFile fp) $ \e -> + if isDoesNotExistError e + then return $ Left $ strStringFileNotFound fp + else return $ Left $ strStringCannotOpenFile fp + +-- ** Error messages + +-- | File-not-found message. +strStringFileNotFound :: FilePath -> String +strStringFileNotFound fp = "File not found: " ++ fp + +-- | Cannot-open-file message. +strStringCannotOpenFile :: FilePath -> String +strStringCannotOpenFile fp = "Error opening file: " ++ fp + +-- * Sanitization + +-- | Remove extraneous characters from an identifier and make the starting +-- character lowercase. +-- +-- This function currently replaces hyphens with underscores. +sanitizeLCIdentifier :: String -> String +sanitizeLCIdentifier = headToLower . map sanitizeCharacter + where + sanitizeCharacter '-' = '_' + sanitizeCharacter x = x + + headToLower :: [Char] -> [Char] + headToLower [] = [] + headToLower (x:xs) = toLower x : xs + +-- | Remove extraneous characters from an identifier and make the starting +-- character uppercase. +-- +-- This function currently replaces hyphens with underscores. +sanitizeUCIdentifier :: String -> String +sanitizeUCIdentifier = headToUpper . map sanitizeCharacter + where + sanitizeCharacter '-' = '_' + sanitizeCharacter x = x + + headToUpper :: [Char] -> [Char] + headToUpper [] = [] + headToUpper (x:xs) = toUpper x : xs diff --git a/src/System/Directory/Extra.hs b/src/System/Directory/Extra.hs new file mode 100644 --- /dev/null +++ b/src/System/Directory/Extra.hs @@ -0,0 +1,81 @@ +-- Copyright 2020 United States Government as represented by the Administrator +-- of the National Aeronautics and Space Administration. All Rights Reserved. +-- +-- Disclaimers +-- +-- No Warranty: THE SUBJECT SOFTWARE IS PROVIDED "AS IS" WITHOUT ANY WARRANTY +-- OF ANY KIND, EITHER EXPRESSED, IMPLIED, OR STATUTORY, INCLUDING, BUT NOT +-- LIMITED TO, ANY WARRANTY THAT THE SUBJECT SOFTWARE WILL CONFORM TO +-- SPECIFICATIONS, ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A +-- PARTICULAR PURPOSE, OR FREEDOM FROM INFRINGEMENT, ANY WARRANTY THAT THE +-- SUBJECT SOFTWARE WILL BE ERROR FREE, OR ANY WARRANTY THAT DOCUMENTATION, IF +-- PROVIDED, WILL CONFORM TO THE SUBJECT SOFTWARE. THIS AGREEMENT DOES NOT, IN +-- ANY MANNER, CONSTITUTE AN ENDORSEMENT BY GOVERNMENT AGENCY OR ANY PRIOR +-- RECIPIENT OF ANY RESULTS, RESULTING DESIGNS, HARDWARE, SOFTWARE PRODUCTS OR +-- ANY OTHER APPLICATIONS RESULTING FROM USE OF THE SUBJECT SOFTWARE. FURTHER, +-- GOVERNMENT AGENCY DISCLAIMS ALL WARRANTIES AND LIABILITIES REGARDING +-- THIRD-PARTY SOFTWARE, IF PRESENT IN THE ORIGINAL SOFTWARE, AND DISTRIBUTES +-- IT "AS IS." +-- +-- Waiver and Indemnity: RECIPIENT AGREES TO WAIVE ANY AND ALL CLAIMS AGAINST +-- THE UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS +-- ANY PRIOR RECIPIENT. IF RECIPIENT'S USE OF THE SUBJECT SOFTWARE RESULTS IN +-- ANY LIABILITIES, DEMANDS, DAMAGES, EXPENSES OR LOSSES ARISING FROM SUCH USE, +-- INCLUDING ANY DAMAGES FROM PRODUCTS BASED ON, OR RESULTING FROM, RECIPIENT'S +-- USE OF THE SUBJECT SOFTWARE, RECIPIENT SHALL INDEMNIFY AND HOLD HARMLESS THE +-- UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS ANY +-- PRIOR RECIPIENT, TO THE EXTENT PERMITTED BY LAW. RECIPIENT'S SOLE REMEDY +-- FOR ANY SUCH MATTER SHALL BE THE IMMEDIATE, UNILATERAL TERMINATION OF THIS +-- AGREEMENT. +-- +-- | Auxiliary functions for working with directories. +module System.Directory.Extra + ( copyDirectoryRecursive + , copyFile' + ) + where + +-- External imports +import qualified Control.Exception as E +import Distribution.Simple.Utils ( getDirectoryContentsRecursive ) +import System.Directory ( copyFile, + createDirectoryIfMissing ) +import System.Exit ( ExitCode (ExitFailure), exitWith ) +import System.FilePath ( takeDirectory, () ) +import System.IO ( hPutStrLn, stderr ) + +-- | Copy all files from one directory to another. +copyDirectoryRecursive :: FilePath -- ^ Source directory + -> FilePath -- ^ Target directory + -> IO () +copyDirectoryRecursive sourceDir targetDir = + E.handle (copyDirectoryRecursiveErrorHandler sourceDir targetDir) $ do + -- Obtain files in source directory + files <- getDirectoryContentsRecursive sourceDir + + -- Determine the actual source and destination path for a file. + let sourceAndDest file = (src, dest) + where + src = sourceDir file + dest = targetDir file + + -- Copy all the files, replacing the top directory. + mapM_ (copyFile' . sourceAndDest) files + +-- | Copy file origin to dest, creating the target directory if it does not +-- exist. +copyFile' :: (FilePath, FilePath) -> IO () +copyFile' (origin, dest) = do + createDirectoryIfMissing True (takeDirectory dest) + copyFile origin dest + +-- | Handle the case in which the source directory cannot be copied or the +-- target directory cannot be created/written. +copyDirectoryRecursiveErrorHandler :: FilePath + -> FilePath + -> E.SomeException + -> IO () +copyDirectoryRecursiveErrorHandler sourceDir targetDir _exception = do + hPutStrLn stderr $ + "ogma: error: cannot copy " ++ sourceDir ++ " to " ++ targetDir + exitWith (ExitFailure 1) diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,104 @@ +-- Copyright 2020 United States Government as represented by the Administrator +-- of the National Aeronautics and Space Administration. All Rights Reserved. +-- +-- Disclaimers +-- +-- No Warranty: THE SUBJECT SOFTWARE IS PROVIDED "AS IS" WITHOUT ANY WARRANTY +-- OF ANY KIND, EITHER EXPRESSED, IMPLIED, OR STATUTORY, INCLUDING, BUT NOT +-- LIMITED TO, ANY WARRANTY THAT THE SUBJECT SOFTWARE WILL CONFORM TO +-- SPECIFICATIONS, ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A +-- PARTICULAR PURPOSE, OR FREEDOM FROM INFRINGEMENT, ANY WARRANTY THAT THE +-- SUBJECT SOFTWARE WILL BE ERROR FREE, OR ANY WARRANTY THAT DOCUMENTATION, IF +-- PROVIDED, WILL CONFORM TO THE SUBJECT SOFTWARE. THIS AGREEMENT DOES NOT, IN +-- ANY MANNER, CONSTITUTE AN ENDORSEMENT BY GOVERNMENT AGENCY OR ANY PRIOR +-- RECIPIENT OF ANY RESULTS, RESULTING DESIGNS, HARDWARE, SOFTWARE PRODUCTS OR +-- ANY OTHER APPLICATIONS RESULTING FROM USE OF THE SUBJECT SOFTWARE. FURTHER, +-- GOVERNMENT AGENCY DISCLAIMS ALL WARRANTIES AND LIABILITIES REGARDING +-- THIRD-PARTY SOFTWARE, IF PRESENT IN THE ORIGINAL SOFTWARE, AND DISTRIBUTES +-- IT "AS IS."
 +-- +-- Waiver and Indemnity: RECIPIENT AGREES TO WAIVE ANY AND ALL CLAIMS AGAINST +-- THE UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS +-- ANY PRIOR RECIPIENT. IF RECIPIENT'S USE OF THE SUBJECT SOFTWARE RESULTS IN +-- ANY LIABILITIES, DEMANDS, DAMAGES, EXPENSES OR LOSSES ARISING FROM SUCH USE, +-- INCLUDING ANY DAMAGES FROM PRODUCTS BASED ON, OR RESULTING FROM, RECIPIENT'S +-- USE OF THE SUBJECT SOFTWARE, RECIPIENT SHALL INDEMNIFY AND HOLD HARMLESS THE +-- UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS ANY +-- PRIOR RECIPIENT, TO THE EXTENT PERMITTED BY LAW. RECIPIENT'S SOLE REMEDY +-- FOR ANY SUCH MATTER SHALL BE THE IMMEDIATE, UNILATERAL TERMINATION OF THIS +-- AGREEMENT. +-- +-- | Test ogma-extra internals. +module Main where + +-- External imports +import Data.Either ( isLeft, isRight ) +import Test.Framework ( Test, defaultMainWithOpts ) +import Test.Framework.Providers.QuickCheck2 ( testProperty ) +import Test.QuickCheck ( Property, (==>), Fun (Fun) ) + +-- Internal imports +import Data.List.Extra ( headEither, toHead, toTail ) + +-- | Run all unit tests on Ogma's core. +main :: IO () +main = + defaultMainWithOpts tests mempty + +-- | All unit tests for Ogma's core. +tests :: [Test.Framework.Test] +tests = + [ testProperty "Data.List.Extra.toHead (diag commutativity)" propToHead + , testProperty "Data.List.Extra.toHead (identity)" propToHeadId + , testProperty "Data.List.Extra.toHead (composition)" propToHeadCmp + , testProperty "Data.List.Extra.toHead (length)" propToHeadSameLength + , testProperty "Data.List.Extra.toTail (diag commutativity)" propToTail + , testProperty "Data.List.Extra.toTail (identity)" propToTailId + , testProperty "Data.List.Extra.toTail (composition)" propToTailCmp + , testProperty "Data.List.Extra.toTail (length)" propToTailSameLength + , testProperty "Data.List.Extra.headEither (Right case)" propHeadEitherRight + , testProperty "Data.List.Extra.headEither (Left case)" propHeadEitherLeft + ] + +-- * Data.List.Extra + +-- | Test that 'toHead' applies a transformation to the head of a list. +propToHead :: [Int] -> Fun Int Int -> Property +propToHead xs (Fun _ f) = not (null xs) ==> f (head xs) == head (toHead f xs) + +-- | Test that 'toHead' preserves the identity. +propToHeadId :: [Int] -> Bool +propToHeadId xs = toHead id xs == xs + +-- | Test that 'toHead' preserves function composition. +propToHeadCmp :: [Int] -> Fun Int Int -> Fun Int Int -> Bool +propToHeadCmp xs (Fun _ f) (Fun _ g) = toHead (f . g) xs == toHead f (toHead g xs) + +-- | Test that 'toHead' does not alter the length of the list. +propToHeadSameLength :: [Int] -> Fun Int Int -> Bool +propToHeadSameLength xs (Fun _ f) = length xs == length (toHead f xs) + +-- | Test that 'toTail' applies a transformation to the tail of a list. +propToTail :: [Int] -> Fun Int Int -> Property +propToTail xs (Fun _ f) = not (null xs) ==> fmap f (tail xs) == tail (toTail f xs) + +-- | Test that 'toTail' preserves the identity. +propToTailId :: [Int] -> Bool +propToTailId xs = toTail id xs == xs + +-- | Test that 'toHead' preserves function composition. +propToTailCmp :: [Int] -> Fun Int Int -> Fun Int Int -> Bool +propToTailCmp xs (Fun _ f) (Fun _ g) = toTail (f . g) xs == toTail f (toTail g xs) + +-- | Test that 'toTail' does not alter the length of the list. +propToTailSameLength :: [Int] -> Fun Int Int -> Bool +propToTailSameLength xs (Fun _ f) = length xs == length (toTail f xs) + +-- | Test that 'headEither' returns a 'Right' value if applied to a non-empty +-- list. +propHeadEitherRight :: [Int] -> Property +propHeadEitherRight xs = not (null xs) ==> isRight (headEither xs) + +-- | Test that 'headEither' returns a 'Left' value if applied to an empty list. +propHeadEitherLeft :: [Int] -> Property +propHeadEitherLeft xs = null xs ==> isLeft (headEither xs)