packages feed

bv-sized 0.6.0 → 0.7.0

raw patch · 43 files changed

+142/−8119 lines, 43 filesdep ~containersdep ~parameterized-utils

Dependency ranges changed: containers, parameterized-utils

Files

bv-sized.cabal view
@@ -1,10 +1,11 @@ name:                bv-sized-version:             0.6.0+version:             0.7.0 category:            Bit Vectors synopsis:            a BitVector datatype that is parameterized by the vector width description:   This module defines a width-parameterized 'BitVector' type and various associated   operations that assume a 2's complement representation.+extra-source-files:  changelog.md homepage:            https://github.com/GaloisInc/bv-sized license:             BSD3 license-file:        LICENSE@@ -21,10 +22,10 @@                      , Data.BitVector.Sized.BitLayout   other-modules:       Data.BitVector.Sized.Internal   build-depends:       base >= 4.7 && < 5-                     , containers >= 0.5.10 && < 0.6+                     , containers >= 0.5.10 && < 0.7                      , lens >= 4 && < 5                      , mtl >= 2 && < 3-                     , parameterized-utils+                     , parameterized-utils >= 2.0 && < 3                      , pretty                      , random >= 1.1 && < 1.2                      , QuickCheck >= 2.11 && < 2.12
− cabal.project 
@@ -1,2 +0,0 @@-packages: .-          submodules/parameterized-utils
changelog.md view
@@ -1,11 +1,17 @@ # Changelog for [`bv-sized` package](http://hackage.haskell.org/package/bv-sized) +## 0.7.0 *April 2019*+  * extractWithRepr now takes a NatRepr as an argument to specify the index, which it+    always should have.+  * Updated to recent parameterized-utils hackage release, which fixes the build+    failures in the previous bv-sized release.+ ## 0.6.0 *March 2019*-* changed WithRepr functions to '-* added Num, Bits instances-* bitVector now takes arbitrary Integral argument-* add 'bitLayoutAssignmentList' function (see haddocks for details-* Hid BV constructor, exposed BitVector as pattern+  * changed WithRepr functions to '+  * added Num, Bits instances+  * bitVector now takes arbitrary Integral argument+  * add 'bitLayoutAssignmentList' function (see haddocks for details+  * Hid BV constructor, exposed BitVector as pattern  ## 0.5.1 *August 2018*   * fixed github URL
src/Data/BitVector/Sized/App.hs view
@@ -33,9 +33,9 @@   ( BVApp(..)   , evalBVApp   , evalBVAppM+  , bvAppWidth   -- * Smart constructors   , BVExpr(..)-  , litBV   -- ** Bitwise   , andE   , orE@@ -70,7 +70,7 @@  import Control.Monad.Identity import Data.BitVector.Sized-import Data.Bits+-- import Data.Bits import Data.Parameterized import Data.Parameterized.TH.GADT import Foreign.Marshal.Utils (fromBool)@@ -79,31 +79,29 @@ -- | Represents the application of a 'BitVector' operation to one or more -- subexpressions. data BVApp (expr :: Nat -> *) (w :: Nat) where-  -- Literal BitVector-  LitBVApp :: BitVector w -> BVApp expr w    -- Bitwise operations-  AndApp :: !(expr w) -> !(expr w) -> BVApp expr w-  OrApp  :: !(expr w) -> !(expr w) -> BVApp expr w-  XorApp :: !(expr w) -> !(expr w) -> BVApp expr w-  NotApp :: !(expr w) -> BVApp expr w+  AndApp :: !(NatRepr w) -> !(expr w) -> !(expr w) -> BVApp expr w+  OrApp  :: !(NatRepr w) -> !(expr w) -> !(expr w) -> BVApp expr w+  XorApp :: !(NatRepr w) -> !(expr w) -> !(expr w) -> BVApp expr w+  NotApp :: !(NatRepr w) -> !(expr w) -> BVApp expr w    -- Shifts-  SllApp :: !(expr w) -> !(expr w) -> BVApp expr w-  SrlApp :: !(expr w) -> !(expr w) -> BVApp expr w-  SraApp :: !(expr w) -> !(expr w) -> BVApp expr w+  SllApp :: !(NatRepr w) -> !(expr w) -> !(expr w) -> BVApp expr w+  SrlApp :: !(NatRepr w) -> !(expr w) -> !(expr w) -> BVApp expr w+  SraApp :: !(NatRepr w) -> !(expr w) -> !(expr w) -> BVApp expr w    -- Arithmetic operations-  AddApp   :: !(expr w) -> !(expr w) -> BVApp expr w-  SubApp   :: !(expr w) -> !(expr w) -> BVApp expr w-  MulApp   :: !(expr w) -> !(expr w) -> BVApp expr w-  QuotUApp :: !(expr w) -> !(expr w) -> BVApp expr w-  QuotSApp :: !(expr w) -> !(expr w) -> BVApp expr w-  RemUApp  :: !(expr w) -> !(expr w) -> BVApp expr w-  RemSApp  :: !(expr w) -> !(expr w) -> BVApp expr w-  NegateApp :: !(expr w) -> BVApp expr w-  AbsApp   :: !(expr w) -> BVApp expr w-  SignumApp :: !(expr w) -> BVApp expr w+  AddApp   :: !(NatRepr w) -> !(expr w) -> !(expr w) -> BVApp expr w+  SubApp   :: !(NatRepr w) -> !(expr w) -> !(expr w) -> BVApp expr w+  MulApp   :: !(NatRepr w) -> !(expr w) -> !(expr w) -> BVApp expr w+  QuotUApp :: !(NatRepr w) -> !(expr w) -> !(expr w) -> BVApp expr w+  QuotSApp :: !(NatRepr w) -> !(expr w) -> !(expr w) -> BVApp expr w+  RemUApp  :: !(NatRepr w) -> !(expr w) -> !(expr w) -> BVApp expr w+  RemSApp  :: !(NatRepr w) -> !(expr w) -> !(expr w) -> BVApp expr w+  NegateApp :: !(NatRepr w) -> !(expr w) -> BVApp expr w+  AbsApp   :: !(NatRepr w) -> !(expr w) -> BVApp expr w+  SignumApp :: !(NatRepr w) -> !(expr w) -> BVApp expr w    -- Comparisons   EqApp  :: !(expr w) -> !(expr w) -> BVApp expr 1@@ -113,12 +111,44 @@   -- Width-changing   ZExtApp    :: NatRepr w' -> !(expr w) -> BVApp expr w'   SExtApp    :: NatRepr w' -> !(expr w) -> BVApp expr w'-  ExtractApp :: NatRepr w' -> Int -> !(expr w) -> BVApp expr w'-  ConcatApp  :: !(expr w) -> !(expr w') -> BVApp expr (w+w')+  ExtractApp :: NatRepr w' -> NatRepr ix -> !(expr w) -> BVApp expr w'+  ConcatApp  :: !(NatRepr (w+w')) -> !(expr w) -> !(expr w') -> BVApp expr (w+w')    -- Other operations-  IteApp :: !(expr 1) -> !(expr w) -> !(expr w) -> BVApp expr w+  IteApp :: !(NatRepr w) -> !(expr 1) -> !(expr w) -> !(expr w) -> BVApp expr w +bvAppWidth :: BVApp expr w -> NatRepr w+bvAppWidth (AndApp wRepr _ _) = wRepr+bvAppWidth (OrApp wRepr _ _) = wRepr+bvAppWidth (XorApp wRepr _ _) = wRepr+bvAppWidth (NotApp wRepr _) = wRepr++bvAppWidth (SllApp wRepr _ _) = wRepr+bvAppWidth (SrlApp wRepr _ _) = wRepr+bvAppWidth (SraApp wRepr _ _) = wRepr++bvAppWidth (AddApp wRepr _ _) = wRepr+bvAppWidth (SubApp wRepr _ _) = wRepr+bvAppWidth (MulApp wRepr _ _) = wRepr+bvAppWidth (QuotUApp wRepr _ _) = wRepr+bvAppWidth (QuotSApp wRepr _ _) = wRepr+bvAppWidth (RemUApp wRepr _ _) = wRepr+bvAppWidth (RemSApp wRepr _ _) = wRepr+bvAppWidth (NegateApp wRepr _) = wRepr+bvAppWidth (AbsApp wRepr _) = wRepr+bvAppWidth (SignumApp wRepr _) = wRepr++bvAppWidth (EqApp _ _) = knownNat+bvAppWidth (LtuApp _ _) = knownNat+bvAppWidth (LtsApp _ _) = knownNat++bvAppWidth (ZExtApp wRepr _) = wRepr+bvAppWidth (SExtApp wRepr _) = wRepr+bvAppWidth (ExtractApp wRepr _ _) = wRepr+bvAppWidth (ConcatApp wRepr _ _) = wRepr++bvAppWidth (IteApp wRepr _ _ _) = wRepr+ $(return [])  instance TestEquality expr => TestEquality (BVApp expr) where@@ -156,35 +186,35 @@            => (forall w' . expr w' -> m (BitVector w')) -- ^ expression evaluator            -> BVApp expr w                              -- ^ application            -> m (BitVector w)-evalBVAppM _ (LitBVApp bv) = return bv-evalBVAppM eval (AndApp e1 e2) = bvAnd <$> eval e1 <*> eval e2-evalBVAppM eval (OrApp  e1 e2) = bvOr  <$> eval e1 <*> eval e2-evalBVAppM eval (XorApp e1 e2) = bvXor <$> eval e1 <*> eval e2-evalBVAppM eval (NotApp e)     = bvComplement <$> eval e-evalBVAppM eval (AddApp e1 e2) = bvAdd <$> eval e1 <*> eval e2-evalBVAppM eval (SubApp e1 e2) = bvAdd <$> eval e1 <*> (bvNegate <$> eval e2)-evalBVAppM eval (SllApp e1 e2) = bvShiftL  <$> eval e1 <*> (fromIntegral . bvIntegerU <$> eval e2)-evalBVAppM eval (SrlApp e1 e2) = bvShiftRL <$> eval e1 <*> (fromIntegral . bvIntegerU <$> eval e2)-evalBVAppM eval (SraApp e1 e2) = bvShiftRA <$> eval e1 <*> (fromIntegral . bvIntegerU <$> eval e2)-evalBVAppM eval (MulApp e1 e2) = bvMul <$> eval e1 <*> eval e2-evalBVAppM eval (QuotSApp e1 e2) = bvQuotS  <$> eval e1 <*> eval e2-evalBVAppM eval (QuotUApp e1 e2) = bvQuotU  <$> eval e1 <*> eval e2-evalBVAppM eval (RemSApp  e1 e2) = bvRemS   <$> eval e1 <*> eval e2-evalBVAppM eval (RemUApp  e1 e2) = bvRemU   <$> eval e1 <*> eval e2-evalBVAppM eval (NegateApp e) = bvNegate <$> eval e-evalBVAppM eval (AbsApp e) = bvAbs <$> eval e-evalBVAppM eval (SignumApp e) = bvSignum <$> eval e+evalBVAppM eval (AndApp _ e1 e2) = bvAnd <$> eval e1 <*> eval e2+evalBVAppM eval (OrApp  _ e1 e2) = bvOr  <$> eval e1 <*> eval e2+evalBVAppM eval (XorApp _ e1 e2) = bvXor <$> eval e1 <*> eval e2+evalBVAppM eval (NotApp _ e)     = bvComplement <$> eval e+evalBVAppM eval (AddApp _ e1 e2) = bvAdd <$> eval e1 <*> eval e2+evalBVAppM eval (SubApp _ e1 e2) = bvAdd <$> eval e1 <*> (bvNegate <$> eval e2)+evalBVAppM eval (SllApp _ e1 e2) = bvShiftL  <$> eval e1 <*> (fromIntegral . bvIntegerU <$> eval e2)+evalBVAppM eval (SrlApp _ e1 e2) = bvShiftRL <$> eval e1 <*> (fromIntegral . bvIntegerU <$> eval e2)+evalBVAppM eval (SraApp _ e1 e2) = bvShiftRA <$> eval e1 <*> (fromIntegral . bvIntegerU <$> eval e2)+evalBVAppM eval (MulApp _ e1 e2) = bvMul <$> eval e1 <*> eval e2+evalBVAppM eval (QuotSApp _ e1 e2) = bvQuotS  <$> eval e1 <*> eval e2+evalBVAppM eval (QuotUApp _ e1 e2) = bvQuotU  <$> eval e1 <*> eval e2+evalBVAppM eval (RemSApp  _ e1 e2) = bvRemS   <$> eval e1 <*> eval e2+evalBVAppM eval (RemUApp  _ e1 e2) = bvRemU   <$> eval e1 <*> eval e2+evalBVAppM eval (NegateApp _ e) = bvNegate <$> eval e+evalBVAppM eval (AbsApp _ e) = bvAbs <$> eval e+evalBVAppM eval (SignumApp _ e) = bvSignum <$> eval e evalBVAppM eval (EqApp  e1 e2) = fromBool <$> ((==)  <$> eval e1 <*> eval e2) evalBVAppM eval (LtuApp e1 e2) = fromBool <$> (bvLTU <$> eval e1 <*> eval e2) evalBVAppM eval (LtsApp e1 e2) = fromBool <$> (bvLTS <$> eval e1 <*> eval e2) evalBVAppM eval (ZExtApp wRepr e) = bvZext' wRepr <$> eval e evalBVAppM eval (SExtApp wRepr e) = bvSext' wRepr <$> eval e-evalBVAppM eval (ExtractApp wRepr base e) = bvExtract' wRepr base <$> eval e-evalBVAppM eval (ConcatApp e1 e2) = do+evalBVAppM eval (ExtractApp wRepr ixRepr e) =+  bvExtract' wRepr (fromIntegral $ intValue ixRepr) <$> eval e+evalBVAppM eval (ConcatApp _ e1 e2) = do   e1Val <- eval e1   e2Val <- eval e2   return $ e1Val `bvConcat` e2Val-evalBVAppM eval (IteApp eTest eT eF) = do+evalBVAppM eval (IteApp _ eTest eT eF) = do   testVal <- eval eTest   case testVal of     1 -> eval eT@@ -198,102 +228,101 @@  -- | Typeclass for embedding 'BVApp' constructors into larger expression types. class BVExpr (expr :: Nat -> *) where+  litBV :: BitVector w -> expr w+  exprWidth :: expr w -> NatRepr w   appExpr :: BVApp expr w -> expr w -instance (KnownNat w, BVExpr expr) => Num (BVApp expr w) where-  app1 + app2 = AddApp (appExpr app1) (appExpr app2)-  app1 * app2 = MulApp (appExpr app1) (appExpr app2)-  abs app = AbsApp (appExpr app)-  signum app = SignumApp (appExpr app)-  fromInteger x = LitBVApp (fromInteger x)-  negate app = NegateApp (appExpr app)-  app1 - app2 = SubApp (appExpr app1) (appExpr app2)---- TODO: finish-instance (KnownNat w, BVExpr expr, TestEquality expr) => Bits (BVApp expr w) where-  app1 .&. app2 = AndApp (appExpr app1) (appExpr app2)-  app1 .|. app2 = OrApp (appExpr app1) (appExpr app2)-  app1 `xor` app2 = XorApp (appExpr app1) (appExpr app2)-  complement app = NotApp (appExpr app)-  shiftL app x = SllApp (appExpr app) (litBV (bitVector x))-  shiftR app x = SraApp (appExpr app) (litBV (bitVector x))-  rotate = undefined-  bitSize = undefined-  bitSizeMaybe = undefined-  isSigned = undefined-  testBit = undefined-  bit = undefined-  popCount = undefined+-- -- TODO: finish+-- instance (BVExpr expr) => Num (BVApp expr w) where+--   app1 + app2 = AddApp (appExpr app1) (appExpr app2)+--   app1 * app2 = MulApp (appExpr app1) (appExpr app2)+--   abs app = AbsApp (appExpr app)+--   signum app = SignumApp (appExpr app)+--   fromInteger = undefined+--   negate app = NegateApp (appExpr app)+--   app1 - app2 = SubApp (appExpr app1) (appExpr app2) --- | Literal bit vector.-litBV :: BVExpr expr => BitVector w -> expr w-litBV = appExpr . LitBVApp+-- -- TODO: finish+-- instance (KnownNat w, BVExpr expr, TestEquality expr) => Bits (BVApp expr w) where+--   app1 .&. app2 = AndApp (appExpr app1) (appExpr app2)+--   app1 .|. app2 = OrApp (appExpr app1) (appExpr app2)+--   app1 `xor` app2 = XorApp (appExpr app1) (appExpr app2)+--   complement app = NotApp (appExpr app)+--   shiftL = undefined+--   shiftR = undefined+--   rotate = undefined+--   bitSize = undefined+--   bitSizeMaybe = undefined+--   isSigned = undefined+--   testBit = undefined+--   bit = undefined+--   popCount = undefined  -- | Bitwise and. andE :: BVExpr expr => expr w -> expr w -> expr w-andE e1 e2 = appExpr (AndApp e1 e2)+andE e1 e2 = appExpr (AndApp (exprWidth e1) e1 e2)  -- | Bitwise or. orE :: BVExpr expr => expr w -> expr w -> expr w-orE e1 e2 = appExpr (OrApp e1 e2)+orE e1 e2 = appExpr (OrApp (exprWidth e1) e1 e2)  -- | Bitwise xor. xorE :: BVExpr expr => expr w -> expr w -> expr w-xorE e1 e2 = appExpr (XorApp e1 e2)+xorE e1 e2 = appExpr (XorApp (exprWidth e1) e1 e2)  -- | Bitwise not. notE :: BVExpr expr => expr w -> expr w-notE e = appExpr (NotApp e)+notE e = appExpr (NotApp (exprWidth e) e)  -- | Add two expressions. addE :: BVExpr expr => expr w -> expr w -> expr w-addE e1 e2 = appExpr (AddApp e1 e2)+addE e1 e2 = appExpr (AddApp (exprWidth e1) e1 e2)  -- | Subtract the second expression from the first. subE :: BVExpr expr => expr w -> expr w -> expr w-subE e1 e2 = appExpr (SubApp e1 e2)+subE e1 e2 = appExpr (SubApp (exprWidth e1) e1 e2)  -- | Signed multiply two 'BitVector's, doubling the width of the result to hold all -- arithmetic overflow bits. mulE :: BVExpr expr => expr w -> expr w -> expr w-mulE e1 e2 = appExpr (MulApp e1 e2)+mulE e1 e2 = appExpr (MulApp (exprWidth e1) e1 e2)  -- | Signed divide two 'BitVector's, rounding to zero. quotsE :: BVExpr expr => expr w -> expr w -> expr w-quotsE e1 e2 = appExpr (QuotSApp e1 e2)+quotsE e1 e2 = appExpr (QuotSApp (exprWidth e1) e1 e2)  -- | Unsigned divide two 'BitVector's, rounding to zero. quotuE :: BVExpr expr => expr w -> expr w -> expr w-quotuE e1 e2 = appExpr (QuotUApp e1 e2)+quotuE e1 e2 = appExpr (QuotUApp (exprWidth e1) e1 e2)  -- | Remainder after signed division of two 'BitVector's, when rounded to zero. remsE :: BVExpr expr => expr w -> expr w -> expr w-remsE e1 e2 = appExpr (RemSApp e1 e2)+remsE e1 e2 = appExpr (RemSApp (exprWidth e1) e1 e2)  -- | Remainder after unsigned division of two 'BitVector's, when rounded to zero. remuE :: BVExpr expr => expr w -> expr w -> expr w-remuE e1 e2 = appExpr (RemUApp e1 e2)+remuE e1 e2 = appExpr (RemUApp (exprWidth e1) e1 e2)  negateE :: BVExpr expr => expr w -> expr w-negateE e = appExpr (NegateApp e)+negateE e = appExpr (NegateApp (exprWidth e) e)  absE :: BVExpr expr => expr w -> expr w-absE e = appExpr (AbsApp e)+absE e = appExpr (AbsApp (exprWidth e) e)  signumE :: BVExpr expr => expr w -> expr w-signumE e = appExpr (SignumApp e)+signumE e = appExpr (SignumApp (exprWidth e) e)  -- | Left logical shift the first expression by the second. sllE :: BVExpr expr => expr w -> expr w -> expr w-sllE e1 e2 = appExpr (SllApp e1 e2)+sllE e1 e2 = appExpr (SllApp (exprWidth e1) e1 e2)  -- | Left logical shift the first expression by the second. srlE :: BVExpr expr => expr w -> expr w -> expr w-srlE e1 e2 = appExpr (SrlApp e1 e2)+srlE e1 e2 = appExpr (SrlApp (exprWidth e1) e1 e2)  -- | Left logical shift the first expression by the second. sraE :: BVExpr expr => expr w -> expr w -> expr w-sraE e1 e2 = appExpr (SraApp e1 e2)+sraE e1 e2 = appExpr (SraApp (exprWidth e1) e1 e2)  -- | Test for equality of two expressions. eqE :: BVExpr expr => expr w -> expr w -> expr 1@@ -324,17 +353,17 @@ sextE' repr e = appExpr (SExtApp repr e)  -- | Extract bits-extractE :: (BVExpr expr, KnownNat w') => Int -> expr w -> expr w'-extractE base e = appExpr (ExtractApp knownNat base e)+extractE :: (BVExpr expr, KnownNat w') => NatRepr ix -> expr w -> expr w'+extractE ixRepr e = appExpr (ExtractApp knownNat ixRepr e)  -- | Extract bits with an explicit width argument-extractE' :: BVExpr expr => NatRepr w' -> Int -> expr w -> expr w'-extractE' wRepr base e = appExpr (ExtractApp wRepr base e)+extractE' :: BVExpr expr => NatRepr w' -> NatRepr ix -> expr w -> expr w'+extractE' wRepr ixRepr e = appExpr (ExtractApp wRepr ixRepr e)  -- | Concatenation concatE :: BVExpr expr => expr w -> expr w' -> expr (w+w')-concatE e1 e2 = appExpr (ConcatApp e1 e2)+concatE e1 e2 = appExpr (ConcatApp (exprWidth e1 `addNat` exprWidth e2) e1 e2)  -- | Conditional branch. iteE :: BVExpr expr => expr 1 -> expr w -> expr w -> expr w-iteE t e1 e2 = appExpr (IteApp t e1 e2)+iteE t e1 e2 = appExpr (IteApp (exprWidth e1) t e1 e2)
src/Data/BitVector/Sized/Internal.hs view
@@ -411,8 +411,9 @@  prettyHex :: (Integral a, PrintfArg a, Show a) => a -> Integer -> String prettyHex width val = printf format val width-  where numDigits = (width+3) `quot` 4-        format = "0x%." ++ show numDigits ++ "x<%d>"+  where -- numDigits = (width+3) `quot` 4+        -- format = "0x%." ++ show numDigits ++ "x<%d>"+        format = "0x%x<%d>"  instance Pretty (BitVector w) where   -- | Pretty print a bit vector (shows its width)
− submodules/parameterized-utils/.git 
@@ -1,1 +0,0 @@-gitdir: ../../.git/modules/submodules/parameterized-utils
− submodules/parameterized-utils/.gitignore 
@@ -1,23 +0,0 @@-/build/-/dependencies/-/dependencies-.cabal-sandbox-.stack-work-**/cabal.config-cabal.sandbox.config-dist-TAGS-unitTest.tix-hpc_report-stack.yaml-/dist-newstyle-.*.swp-.vagrant-graphmod-.hlint.yaml-cabal.project.local-dist-newstyle/-.boring-_darcs/-.cmd_history-*~
− submodules/parameterized-utils/.travis.yml 
@@ -1,103 +0,0 @@-# This Travis job script has been generated by a script via-#-#   runghc make_travis_yml_2.hs 'parameterized-utils.cabal'-#-# For more information, see https://github.com/haskell-CI/haskell-ci-#-language: c-sudo: false--git:-  submodules: false  # whether to recursively clone submodules--cache:-  directories:-    - $HOME/.cabal/packages-    - $HOME/.cabal/store--before_cache:-  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log-  # remove files that are regenerated by 'cabal update'-  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*-  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json-  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache-  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar-  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx--  - rm -rfv $HOME/.cabal/packages/head.hackage--matrix:-  include:-    - compiler: "ghc-8.4.3"-    # env: TEST=--disable-tests BENCH=--disable-benchmarks-      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}--before_install:-  - HC=${CC}-  - HCPKG=${HC/ghc/ghc-pkg}-  - unset CC-  - ROOTDIR=$(pwd)-  - mkdir -p $HOME/.local/bin-  - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"-  - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))-  - echo $HCNUMVER--install:-  - cabal --version-  - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"-  - BENCH=${BENCH---enable-benchmarks}-  - TEST=${TEST---enable-tests}-  - HADDOCK=${HADDOCK-true}-  - UNCONSTRAINED=${UNCONSTRAINED-true}-  - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}-  - GHCHEAD=${GHCHEAD-false}-  - travis_retry cabal update -v-  - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"-  - rm -fv cabal.project cabal.project.local-  - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'-  - "printf 'packages: \".\"\\n' > cabal.project"-  - touch cabal.project.local-  - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg  | grep -vw -- parameterized-utils | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"-  - cat cabal.project || true-  - cat cabal.project.local || true-  - if [ -f "./configure.ac" ]; then-      (cd "." && autoreconf -i);-    fi-  - rm -f cabal.project.freeze-  - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all-  - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all-  - rm -rf .ghc.environment.* "."/dist-  - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)--# Here starts the actual work to be performed for the package under test;-# any command which exits with a non-zero exit code causes the build to fail.-script:-  # test that source-distributions can be generated-  - (cd "." && cabal sdist)-  - mv "."/dist/parameterized-utils-*.tar.gz ${DISTDIR}/-  - cd ${DISTDIR} || false-  - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;-  - "printf 'packages: parameterized-utils-*/*.cabal\\n' > cabal.project"-  - touch cabal.project.local-  - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg  | grep -vw -- parameterized-utils | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"-  - cat cabal.project || true-  - cat cabal.project.local || true-  # this builds all libraries and executables (without tests/benchmarks)-  - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all--  # build & run tests, build benchmarks-  - cabal new-build -w ${HC} ${TEST} ${BENCH} all-  - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi--  # cabal check-  - (cd parameterized-utils-* && cabal check)--  # haddock-  - rm -rf ./dist-newstyle-  - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi--  # Build without installed constraints for packages in global-db-  - if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi--# REGENDATA ["parameterized-utils.cabal"]-# EOF
− submodules/parameterized-utils/LICENSE 
@@ -1,30 +0,0 @@-Copyright (c) 2013-2016 Galois Inc.-All rights reserved.--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 Galois, Inc. 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.
− submodules/parameterized-utils/README.md 
@@ -1,7 +0,0 @@-The parameterized-utils module contains a collection of typeclasses-and datatypes for working with parameterized types, that is types that-have a type argument.  One example would be a algebraic data type-for expressions, that use a type parameter to describe the type of the-expression.--This packaged provides collections classes for these parameterized types.
− submodules/parameterized-utils/parameterized-utils.cabal 
@@ -1,109 +0,0 @@-Name:          parameterized-utils-Version:       1.0.8-Author:        Galois Inc.-Maintainer:    jhendrix@galois.com-Build-type:    Simple-Cabal-version: >= 1.9.2-license: BSD3-license-file: LICENSE-category: Data Structures, Dependent Types-Synopsis: Classes and data structures for working with data-kind indexed types-Description:-  This packages contains collection classes and type representations-  used for working with values that have a single parameter.  It's-  intended for things like expression libraries where one wishes-  to leverage the Haskell type-checker to improve type-safety by encoding-  the object language type system into data kinds.-tested-with: GHC==8.4.3, GHC==8.6.1---- Many (but not all, sadly) uses of unsafe operations are--- controlled by this compile flag.  When this flag is set--- to False, alternate implementations are used to avoid--- Unsafe.Coerce and Data.Coerce.  These alternate implementations--- impose a significant performance hit.-flag unsafe-operations-  Description: Use unsafe operations to improve performance-  Default: True--source-repository head-  type: git-  location: https://github.com/GaloisInc/parameterized-utils--library-  build-depends:-    base >= 4.7 && < 4.13,-    th-abstraction >=0.1 && <0.3,-    constraints >= 0.10 && < 0.11,-    containers,-    deepseq,-    ghc-prim,-    hashable,-    hashtables,-    lens,-    mtl,-    template-haskell,-    text,-    vector--  hs-source-dirs: src--  exposed-modules:-    Data.Parameterized-    Data.Parameterized.Classes-    Data.Parameterized.ClassesC-    Data.Parameterized.Compose-    Data.Parameterized.Context-    Data.Parameterized.Context.Safe-    Data.Parameterized.Context.Unsafe-    Data.Parameterized.Ctx-    Data.Parameterized.Ctx.Proofs-    Data.Parameterized.DecidableEq-    Data.Parameterized.HashTable-    Data.Parameterized.List-    Data.Parameterized.Map-    Data.Parameterized.NatRepr-    Data.Parameterized.Nonce-    Data.Parameterized.Nonce.Transformers-    Data.Parameterized.Nonce.Unsafe-    Data.Parameterized.Pair-    Data.Parameterized.Peano-    Data.Parameterized.Some-    Data.Parameterized.SymbolRepr-    Data.Parameterized.TH.GADT-    Data.Parameterized.TraversableF-    Data.Parameterized.TraversableFC-    Data.Parameterized.Utils.BinTree-    Data.Parameterized.Utils.Endian-    Data.Parameterized.Vector--  ghc-options: -Wall--  if flag(unsafe-operations)-    cpp-options: -DUNSAFE_OPS---test-suite parameterizedTests-  type: exitcode-stdio-1.0-  hs-source-dirs: test--  ghc-options: -Wall--  main-is:UnitTest.hs-  other-modules:-    Test.Context-    Test.NatRepr-    Test.Vector--  build-depends:-    base,-    hashable,-    hashtables,-    ghc-prim,-    lens,-    mtl,-    parameterized-utils,-    tasty,-    tasty-ant-xml >= 1.1.0,-    tasty-hunit,-    tasty-quickcheck >= 0.8.1,-    QuickCheck >= 2.7
− submodules/parameterized-utils/src/Data/Parameterized.hs 
@@ -1,19 +0,0 @@-module Data.Parameterized-( module Data.Parameterized.Classes       -, module Data.Parameterized.Ctx           -, module Data.Parameterized.TraversableF  -, module Data.Parameterized.TraversableFC -, module Data.Parameterized.NatRepr       -, module Data.Parameterized.Pair          -, module Data.Parameterized.Some          -, module Data.Parameterized.SymbolRepr    -) where--import Data.Parameterized.Classes-import Data.Parameterized.Ctx-import Data.Parameterized.TraversableF-import Data.Parameterized.TraversableFC-import Data.Parameterized.NatRepr-import Data.Parameterized.Pair-import Data.Parameterized.Some-import Data.Parameterized.SymbolRepr
− submodules/parameterized-utils/src/Data/Parameterized/Classes.hs 
@@ -1,307 +0,0 @@-{-|-Copyright        : (c) Galois, Inc 2014-2015-Maintainer       : Joe Hendrix <jhendrix@galois.com>--This module declares classes for working with types with the kind-@k -> *@ for any kind @k@.  These are generalizations of the-"Data.Functor.Classes" types as they work with any kind @k@, and are-not restricted to '*'.--}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-#if MIN_VERSION_base(4,9,0)-{-# LANGUAGE Safe #-}-#else-{-# LANGUAGE Trustworthy #-}-#endif-module Data.Parameterized.Classes-  ( -- * Equality exports-    Equality.TestEquality(..)-  , (Equality.:~:)(..)-  , EqF(..)-  , PolyEq(..)-    -- * Ordering generalization-  , OrdF(..)-  , lexCompareF-  , OrderingF(..)-  , joinOrderingF-  , orderingF_refl-  , toOrdering-  , fromOrdering-  , ordFCompose-    -- * Typeclass generalizations-  , ShowF(..)-  , showsF-  , HashableF(..)-  , CoercibleF(..)-    -- * Optics generalizations-  , IndexF-  , IxValueF-  , IxedF(..)-  , IxedF'(..)-  , AtF(..)-    -- * KnownRepr-  , KnownRepr(..)-    -- * Re-exports-  , Data.Maybe.isJust-  ) where--import Data.Functor.Const-import Data.Functor.Compose (Compose(..))-import Data.Hashable-import Data.Maybe (isJust)-import Data.Proxy-import Data.Type.Equality as Equality--import Data.Parameterized.Compose ()---- We define these type alias here to avoid importing Control.Lens--- modules, as this apparently causes problems with the safe Hasekll--- checking.-type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s-type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s----------------------------------------------------------------------------- CoercibleF---- | An instance of 'CoercibleF' gives a way to coerce between---   all the types of a family.  We generally use this to witness---   the fact that the type parameter to @rtp@ is a phantom type---   by giving an implementation in terms of Data.Coerce.coerce.-class CoercibleF (rtp :: k -> *) where-  coerceF :: rtp a -> rtp b--instance CoercibleF (Const x) where-  coerceF (Const x) = Const x----------------------------------------------------------------------------- EqF---- | @EqF@ provides a method @eqF@ for testing whether two parameterized--- types are equal.------ Unlike 'TestEquality', this only works when the type arguments are--- the same, and does not provide a proof that the types have the same--- type when they are equal. Thus this can be implemented over--- parameterized types that are unable to provide evidence that their--- type arguments are equal.-class EqF (f :: k -> *) where-  eqF :: f a -> f a -> Bool--instance Eq a => EqF (Const a) where-  eqF (Const x) (Const y) = x == y----------------------------------------------------------------------------- PolyEq---- | A polymorphic equality operator that generalizes 'TestEquality'.-class PolyEq u v where-  polyEqF :: u -> v -> Maybe (u :~: v)--  polyEq :: u -> v -> Bool-  polyEq x y = isJust (polyEqF x y)----------------------------------------------------------------------------- Ordering---- | Ordering over two distinct types with a proof they are equal.-data OrderingF x y where-  LTF :: OrderingF x y-  EQF :: OrderingF x x-  GTF :: OrderingF x y--orderingF_refl :: OrderingF x y -> Maybe (x :~: y)-orderingF_refl o =-  case o of-    LTF -> Nothing-    EQF -> Just Refl-    GTF -> Nothing---- | Convert 'OrderingF' to standard ordering.-toOrdering :: OrderingF x y -> Ordering-toOrdering LTF = LT-toOrdering EQF = EQ-toOrdering GTF = GT---- | Convert standard ordering to 'OrderingF'.-fromOrdering :: Ordering -> OrderingF x x-fromOrdering LT = LTF-fromOrdering EQ = EQF-fromOrdering GT = GTF---- | `joinOrderingF x y` first compares on x, returning an equivalent--- value if it is not `EQF`.  If it is EQF, it returns `y`.-joinOrderingF :: forall (a :: j) (b :: j) (c :: k) (d :: k)-              .  OrderingF a b-              -> (a ~ b => OrderingF c d)-              -> OrderingF c d-joinOrderingF EQF y = y-joinOrderingF LTF _ = LTF-joinOrderingF GTF _ = GTF----------------------------------------------------------------------------- OrdF---- | A parameterized type that can be compared on distinct instances.-class TestEquality ktp => OrdF (ktp :: k -> *) where-  {-# MINIMAL compareF #-}--  -- | compareF compares two keys with different type parameters.-  -- Instances must ensure that keys are only equal if the type-  -- parameters are equal.-  compareF :: ktp x -> ktp y -> OrderingF x y--  leqF :: ktp x -> ktp y -> Bool-  leqF x y =-    case compareF x y of-      LTF -> True-      EQF -> True-      GTF -> False--  ltF :: ktp x -> ktp y -> Bool-  ltF x y =-    case compareF x y of-      LTF -> True-      EQF -> False-      GTF -> False--  geqF :: ktp x -> ktp y -> Bool-  geqF x y =-    case compareF x y of-      LTF -> False-      EQF -> True-      GTF -> True--  gtF :: ktp x -> ktp y -> Bool-  gtF x y =-    case compareF x y of-      LTF -> False-      EQF -> False-      GTF -> True---- | Compare two values, and if they are equal compare the next values,--- otherwise return LTF or GTF-lexCompareF :: forall (f :: j -> *) (a :: j) (b :: j) (c :: k) (d :: k)-             .  OrdF f-            => f a-            -> f b-            -> (a ~ b => OrderingF c d)-            -> OrderingF c d-lexCompareF x y = joinOrderingF (compareF x y)---- | If the \"outer\" functor has an 'OrdF' instance, then one can be generated--- for the \"inner\" functor. The type-level evidence of equality is deduced--- via generativity of @g@, e.g. the inference @g x ~ g y@ implies @x ~ y@.-ordFCompose :: forall (f :: k -> *) (g :: l -> k) x y.-                (forall w z. f w -> f z -> OrderingF w z)-            -> Compose f g x-            -> Compose f g y-            -> OrderingF x y-ordFCompose ordF_ (Compose x) (Compose y) =-  case ordF_ x y of-    LTF -> LTF-    GTF -> GTF-    EQF -> EQF--instance OrdF f => OrdF (Compose f g) where-  compareF x y = ordFCompose compareF x y----------------------------------------------------------------------------- ShowF---- | A parameterized type that can be shown on all instances.------ To implement @'ShowF' g@, one should implement an instance @'Show'--- (g tp)@ for all argument types @tp@, then write an empty instance--- @instance 'ShowF' g@.-class ShowF (f :: k -> *) where-  -- | Provides a show instance for each type.-  withShow :: p f -> q tp -> (Show (f tp) => a) -> a--  default withShow :: Show (f tp) => p f -> q tp -> (Show (f tp) => a) -> a-  withShow _ _ x = x--  showF :: forall tp . f tp -> String-  showF x = withShow (Proxy :: Proxy f) (Proxy :: Proxy tp) (show x)--  -- | Like 'showsPrec', the precedence argument is /one more/ than the-  -- precedence of the enclosing context.-  showsPrecF :: forall tp. Int -> f tp -> String -> String-  showsPrecF p x = withShow (Proxy :: Proxy f) (Proxy :: Proxy tp) (showsPrec p x)--showsF :: ShowF f => f tp -> String -> String-showsF x = showsPrecF 0 x--instance Show x => ShowF (Const x)----------------------------------------------------------------------------- IxedF--type family IndexF       (m :: *) :: k -> *-type family IxValueF     (m :: *) :: k -> *---- | Parameterized generalization of the lens @Ixed@ class.-class IxedF k m where-  -- | Given an index into a container, build a traversal that visits-  --   the given element in the container, if it exists.-  ixF :: forall (x :: k). IndexF m x -> Traversal' m (IxValueF m x)---- | Parameterized generalization of the lens @Ixed@ class,---   but with the guarantee that indexes exist in the container.-class IxedF k m => IxedF' k m where-  -- | Given an index into a container, build a lens that-  --   points into the given element in the container.-  ixF' :: forall (x :: k). IndexF m x -> Lens' m (IxValueF m x)----------------------------------------------------------------------------- AtF---- | Parameterized generalization of the lens @At@ class.-class IxedF k m => AtF k m where-  -- | Given an index into a container, build a lens that points into-  --   the given position in the container, whether or not it currently-  --   exists.  Setting values of @atF@ to a @Just@ value will insert-  --   the value if it does not already exist.-  atF :: forall (x :: k). IndexF m x -> Lens' m (Maybe (IxValueF m x))----------------------------------------------------------------------------- HashableF---- | A default salt used in the implementation of 'hash'.-defaultSalt :: Int-#if WORD_SIZE_IN_BITS == 64-defaultSalt = 0xdc36d1615b7400a4-#else-defaultSalt = 0x087fc72c-#endif-{-# INLINE defaultSalt #-}---- | A parameterized type that is hashable on all instances.-class HashableF (f :: k -> *) where-  hashWithSaltF :: Int -> f tp -> Int--  -- | Hash with default salt.-  hashF :: f tp -> Int-  hashF = hashWithSaltF defaultSalt--instance Hashable a => HashableF (Const a) where-  hashWithSaltF s (Const x) = hashWithSalt s x----------------------------------------------------------------------------- KnownRepr---- | This class is parameterized by a kind @k@ (typically a data--- kind), a type constructor @f@ of kind @k -> *@ (typically a GADT of--- singleton types indexed by @k@), and an index parameter @ctx@ of--- kind @k@.-class KnownRepr (f :: k -> *) (ctx :: k) where-  knownRepr :: f ctx
− submodules/parameterized-utils/src/Data/Parameterized/ClassesC.hs 
@@ -1,52 +0,0 @@-{-|-Copyright        : (c) Galois, Inc 2014-2015-Maintainer       : Langston Barrett <langston@galois.com>--This module declares classes for working with types with the kind-@(k -> *) -> *@ for any kind @k@.--These classes generally require type-level evidence for operations-on their subterms, but don't actually provide it themselves (because-their types are not themselves parameterized, unlike those in-"Data.Parameterized.TraverableFC").--Note that there is still some ambiguity around naming conventions, see-<https://github.com/GaloisInc/parameterized-utils/issues/23 issue 23>.--}--{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE Safe #-}-{-# LANGUAGE TypeOperators #-}--module Data.Parameterized.ClassesC-  ( TestEqualityC(..)-  , OrdC(..)-  ) where--import Data.Type.Equality ((:~:)(..))-import Data.Maybe (isJust)-import Data.Parameterized.Classes (OrderingF, toOrdering)-import Data.Parameterized.Some (Some(..))--class TestEqualityC (t :: (k -> *) -> *) where-  testEqualityC :: (forall x y. f x -> f y -> Maybe (x :~: y))-                -> t f-                -> t f-                -> Bool--class TestEqualityC t => OrdC (t :: (k -> *) -> *) where-  compareC :: (forall x y. f x -> g y -> OrderingF x y)-           -> t f-           -> t g-           -> Ordering---- | This instance demonstrates where the above class is useful: namely, in--- types with existential quantification.-instance TestEqualityC Some where-  testEqualityC subterms (Some someone) (Some something) =-    isJust (subterms someone something)--instance OrdC Some where-  compareC subterms (Some someone) (Some something) =-    toOrdering (subterms someone something)
− submodules/parameterized-utils/src/Data/Parameterized/Compose.hs 
@@ -1,45 +0,0 @@-{-|-Copyright        : (c) Galois, Inc 2014-2018-Maintainer       : Langston Barrett <langston@galois.com--Utilities for working with "Data.Functor.Compose".--NB: This module contains an orphan instance. It will be included in GHC 8.10,-see https://gitlab.haskell.org/ghc/ghc/merge_requests/273.--}--{-# LANGUAGE GADTs #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE Safe #-}--module Data.Parameterized.Compose-  ( testEqualityComposeBare-  ) where--import Data.Functor.Compose-import Data.Type.Equality---- | The deduction (via generativity) that if @g x :~: g y@ then @x :~: y@.------ See https://gitlab.haskell.org/ghc/ghc/merge_requests/273.-testEqualityComposeBare :: forall (f :: k -> *) (g :: l -> k) x y.-                           (forall w z. f w -> f z -> Maybe (w :~: z))-                        -> Compose f g x-                        -> Compose f g y-                        -> Maybe (x :~: y)-testEqualityComposeBare testEquality_ (Compose x) (Compose y) =-  case (testEquality_ x y :: Maybe (g x :~: g y)) of-    Just Refl -> Just (Refl :: x :~: y)-    Nothing   -> Nothing--testEqualityCompose :: forall (f :: k -> *) (g :: l -> k) x y. (TestEquality f)-                    => Compose f g x-                    -> Compose f g y-                    -> Maybe (x :~: y)-testEqualityCompose = testEqualityComposeBare testEquality--instance (TestEquality f) => TestEquality (Compose f g) where-  testEquality = testEqualityCompose
− submodules/parameterized-utils/src/Data/Parameterized/Context.hs 
@@ -1,463 +0,0 @@---------------------------------------------------------------------------- |--- Module           : Data.Parameterized.Context--- Copyright        : (c) Galois, Inc 2014-16--- Maintainer       : Joe Hendrix <jhendrix@galois.com>------ This module reexports either "Data.Parameterized.Context.Safe"--- or "Data.Parameterized.Context.Unsafe" depending on the--- the unsafe-operations compile-time flag.------ It also defines some utility typeclasses for transforming--- between curried and uncurried versions of functions over contexts.---------------------------------------------------------------------------{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE ViewPatterns #-}-module Data.Parameterized.Context- (-#ifdef UNSAFE_OPS-    module Data.Parameterized.Context.Unsafe-#else-    module Data.Parameterized.Context.Safe-#endif-  , singleton-  , toVector-  , pattern (:>)-  , pattern Empty-  , decompose-  , Data.Parameterized.Context.null-  , Data.Parameterized.Context.init-  , Data.Parameterized.Context.last-  , Data.Parameterized.Context.view-  , Data.Parameterized.Context.take-  , forIndexM-  , generateSome-  , generateSomeM-  , fromList-  , traverseAndCollect--    -- * Context extension and embedding utilities-  , CtxEmbedding(..)-  , ExtendContext(..)-  , ExtendContext'(..)-  , ApplyEmbedding(..)-  , ApplyEmbedding'(..)-  , identityEmbedding-  , extendEmbeddingRightDiff-  , extendEmbeddingRight-  , extendEmbeddingBoth-  , appendEmbedding-  , ctxeSize-  , ctxeAssignment--    -- * Static indexing and lenses for assignments-  , Idx-  , field-  , natIndex-  , natIndexProxy-    -- * Currying and uncurrying for assignments-  , CurryAssignment-  , CurryAssignmentClass(..)-    -- * Size and Index values-  , size1, size2, size3, size4, size5, size6-  , i1of2, i2of2-  , i1of3, i2of3, i3of3-  , i1of4, i2of4, i3of4, i4of4-  , i1of5, i2of5, i3of5, i4of5, i5of5-  , i1of6, i2of6, i3of6, i4of6, i5of6, i6of6-  ) where--import           Control.Applicative (liftA2)-import           Control.Lens hiding (Index, (:>), Empty)-import qualified Data.Vector as V-import qualified Data.Vector.Mutable as MV-import           GHC.TypeLits (Nat, type (-))-import           Data.Monoid ((<>))--import           Data.Parameterized.Classes-import           Data.Parameterized.Some-import           Data.Parameterized.TraversableFC--#ifdef UNSAFE_OPS-import           Data.Parameterized.Context.Unsafe-#else-import           Data.Parameterized.Context.Safe-#endif----- | Create a single element context.-singleton :: f tp -> Assignment f (EmptyCtx ::> tp)-singleton = (empty :>)---- |'forIndexM sz f' calls 'f' on indices '[0..sz-1]'.-forIndexM :: forall ctx m-           . Applicative m-          => Size ctx-          -> (forall tp . Index ctx tp -> m ())-          -> m ()-forIndexM sz f = forIndexRange 0 sz (\i r -> f i *> r) (pure ())---- | Generate an assignment with some context type that is not known.-generateSome :: forall f-              . Int-             -> (Int -> Some f)-             -> Some (Assignment f)-generateSome n f = go n-  where go :: Int -> Some (Assignment f)-        go 0 = Some empty-        go i = (\(Some a) (Some e) -> Some (a `extend` e)) (go (i-1)) (f (i-1))---- | Generate an assignment with some context type that is not known.-generateSomeM :: forall m f-              .  Applicative m-              => Int-              -> (Int -> m (Some f))-              -> m (Some (Assignment f))-generateSomeM n f = go n-  where go :: Int -> m (Some (Assignment f))-        go 0 = pure (Some empty)-        go i = (\(Some a) (Some e) -> Some (a `extend` e)) <$> go (i-1) <*> f (i-1)---- | Convert the assignment to a vector.-toVector :: Assignment f tps -> (forall tp . f tp -> e) -> V.Vector e-toVector a f = V.create $ do-  vm <- MV.new (sizeInt (size a))-  forIndexM (size a) $ \i -> do-    MV.write vm (indexVal i) (f (a ! i))-  return vm-{-# INLINABLE toVector #-}------------------------------------------------------------------------------------- Patterns---- | Pattern synonym for the empty assignment-pattern Empty :: () => ctx ~ EmptyCtx => Assignment f ctx-pattern Empty <- (viewAssign -> AssignEmpty)-  where Empty = empty--infixl :>---- | Pattern synonym for extending an assignment on the right-pattern (:>) :: () => ctx' ~ (ctx ::> tp) => Assignment f ctx -> f tp -> Assignment f ctx'-pattern (:>) a v <- (viewAssign -> AssignExtend a v)-  where a :> v = extend a v---- The COMPLETE pragma was not defined until ghc 8.2.*-#if MIN_VERSION_base(4,10,0)-{-# COMPLETE (:>), Empty :: Assignment  #-}-#endif------------------------------------------------------------------------------------- Views---- | Return true if assignment is empty.-null :: Assignment f ctx -> Bool-null a =-  case viewAssign a of-    AssignEmpty -> True-    AssignExtend{} -> False--decompose :: Assignment f (ctx ::> tp) -> (Assignment f ctx, f tp)-decompose x = (Data.Parameterized.Context.init x, Data.Parameterized.Context.last x)---- | Return assignment with all but the last block.-init :: Assignment f (ctx '::> tp) -> Assignment f ctx-init x =-  case viewAssign x of-    AssignExtend t _ -> t---- | Return the last element in the assignment.-last :: Assignment f (ctx '::> tp) -> f tp-last x =-  case viewAssign x of-    AssignExtend _ e -> e--{-# DEPRECATED view "Use viewAssign or the Empty and :> patterns instead." #-}--- | View an assignment as either empty or an assignment with one appended.-view :: forall f ctx . Assignment f ctx -> AssignView f ctx-view = viewAssign--take :: forall f ctx ctx'. Size ctx -> Size ctx' -> Assignment f (ctx <+> ctx') -> Assignment f ctx-take sz sz' asgn =-  let diff = appendDiff sz' in-  generate sz (\i -> asgn ! extendIndex' diff i)------------------------------------------------------------------------------------- Context embedding.---- | This datastructure contains a proof that the first context is--- embeddable in the second.  This is useful if we want to add extend--- an existing term under a larger context.--data CtxEmbedding (ctx :: Ctx k) (ctx' :: Ctx k)-  = CtxEmbedding { _ctxeSize       :: Size ctx'-                 , _ctxeAssignment :: Assignment (Index ctx') ctx-                 }---- Alternate encoding?--- data CtxEmbedding ctx ctx' where---   EIdentity  :: CtxEmbedding ctx ctx---   ExtendBoth :: CtxEmbedding ctx ctx' -> CtxEmbedding (ctx ::> tp) (ctx' ::> tp)---   ExtendOne  :: CtxEmbedding ctx ctx' -> CtxEmbedding ctx (ctx' ::> tp)--ctxeSize :: Simple Lens (CtxEmbedding ctx ctx') (Size ctx')-ctxeSize = lens _ctxeSize (\s v -> s { _ctxeSize = v })--ctxeAssignment :: Lens (CtxEmbedding ctx1 ctx') (CtxEmbedding ctx2 ctx')-                       (Assignment (Index ctx') ctx1) (Assignment (Index ctx') ctx2)-ctxeAssignment = lens _ctxeAssignment (\s v -> s { _ctxeAssignment = v })--class ApplyEmbedding (f :: Ctx k -> *) where-  applyEmbedding :: CtxEmbedding ctx ctx' -> f ctx -> f ctx'--class ApplyEmbedding' (f :: Ctx k -> k' -> *) where-  applyEmbedding' :: CtxEmbedding ctx ctx' -> f ctx v -> f ctx' v--class ExtendContext (f :: Ctx k -> *) where-  extendContext :: Diff ctx ctx' -> f ctx -> f ctx'--class ExtendContext' (f :: Ctx k -> k' -> *) where-  extendContext' :: Diff ctx ctx' -> f ctx v -> f ctx' v--instance ApplyEmbedding' Index where-  applyEmbedding' ctxe idx = (ctxe ^. ctxeAssignment) ! idx--instance ExtendContext' Index where-  extendContext' = extendIndex'---- -- This is the inefficient way of doing things.  A better way is to--- -- just have a map between indices.--- applyEmbedding :: CtxEmbedding ctx ctx'---                -> Index ctx tp -> Index ctx' tp--- applyEmbedding ctxe idx = (ctxe ^. ctxeAssignment) ! idx--identityEmbedding :: Size ctx -> CtxEmbedding ctx ctx-identityEmbedding sz = CtxEmbedding sz (generate sz id)---- emptyEmbedding :: CtxEmbedding EmptyCtx EmptyCtx--- emptyEmbedding = identityEmbedding knownSize--extendEmbeddingRightDiff :: forall ctx ctx' ctx''.-                            Diff ctx' ctx''-                            -> CtxEmbedding ctx ctx'-                            -> CtxEmbedding ctx ctx''-extendEmbeddingRightDiff diff (CtxEmbedding sz' assgn) = CtxEmbedding (extSize sz' diff) updated-  where-    updated :: Assignment (Index ctx'') ctx-    updated = fmapFC (extendIndex' diff) assgn--extendEmbeddingRight :: CtxEmbedding ctx ctx' -> CtxEmbedding ctx (ctx' ::> tp)-extendEmbeddingRight = extendEmbeddingRightDiff knownDiff--appendEmbedding :: Size ctx -> Size ctx' -> CtxEmbedding ctx (ctx <+> ctx')-appendEmbedding sz sz' = CtxEmbedding (addSize sz sz') (generate sz (extendIndex' diff))-  where-  diff = appendDiff sz'--extendEmbeddingBoth :: forall ctx ctx' tp. CtxEmbedding ctx ctx' -> CtxEmbedding (ctx ::> tp) (ctx' ::> tp)-extendEmbeddingBoth ctxe = updated & ctxeAssignment %~ flip extend (nextIndex (ctxe ^. ctxeSize))-  where-    updated :: CtxEmbedding ctx (ctx' ::> tp)-    updated = extendEmbeddingRight ctxe------------------------------------------------------------------------------------- Static indexing based on type-level naturals---- | Get a lens for an position in an 'Assignment' by zero-based, left-to-right position.--- The position must be specified using @TypeApplications@ for the @n@ parameter.-field :: forall n ctx f r. Idx n ctx r => Lens' (Assignment f ctx) (f r)-field = ixF' (natIndex @n)---- | Constraint synonym used for getting an 'Index' into a 'Ctx'.--- @n@ is the zero-based, left-counted index into the list of types--- @ctx@ which has the type @r@.-type Idx n ctx r = (ValidIx n ctx, Idx' (FromLeft ctx n) ctx r)---- | Compute an 'Index' value for a particular position in a 'Ctx'. The--- @TypeApplications@ extension will be needed to disambiguate the choice--- of the type @n@.-natIndex :: forall n ctx r. Idx n ctx r => Index ctx r-natIndex = natIndex' @_ @(FromLeft ctx n)---- | This version of 'natIndex' is suitable for use without the @TypeApplications@--- extension.-natIndexProxy :: forall n ctx r proxy. Idx n ctx r => proxy n -> Index ctx r-natIndexProxy _ = natIndex @n----------------------------------------------------------------------------- Implementation----------------------------------------------------------------------------- | Class for computing 'Index' values for positions in a 'Ctx'.-class KnownContext ctx => Idx' (n :: Nat) (ctx :: Ctx k) (r :: k) | n ctx -> r where-  natIndex' :: Index ctx r---- | Base-case-instance KnownContext xs => Idx' 0 (xs '::> x) x where-  natIndex' = lastIndex knownSize---- | Inductive-step-instance {-# Overlaps #-} (KnownContext xs, Idx' (n-1) xs r) =>-  Idx' n (xs '::> x) r where--  natIndex' = skipIndex (natIndex' @_ @(n-1))-------------------------------------------------------------------------------------- CurryAssignment---- | This type family is used to define currying\/uncurrying operations--- on assignments.  It is best understood by seeing its evaluation on--- several examples:------ > CurryAssignment EmptyCtx f x = x--- > CurryAssignment (EmptyCtx ::> a) f x = f a -> x--- > CurryAssignment (EmptyCtx ::> a ::> b) f x = f a -> f b -> x--- > CurryAssignment (EmptyCtx ::> a ::> b ::> c) f x = f a -> f b -> f c -> x-type family CurryAssignment (ctx :: Ctx k) (f :: k -> *) (x :: *) :: * where-   CurryAssignment EmptyCtx    f x = x-   CurryAssignment (ctx ::> a) f x = CurryAssignment ctx f (f a -> x)---- | This class implements two methods that witness the isomorphism between---   curried and uncurried functions.-class CurryAssignmentClass (ctx :: Ctx k) where--  -- | Transform a function that accepts an assignment into one with a separate-  --   variable for each element of the assignment.-  curryAssignment   :: (Assignment f ctx -> x) -> CurryAssignment ctx f x--  -- | Transform a curried function into one that accepts an assignment value.-  uncurryAssignment :: CurryAssignment ctx f x -> (Assignment f ctx -> x)--instance CurryAssignmentClass EmptyCtx where-  curryAssignment k = k empty-  uncurryAssignment k _ = k--instance CurryAssignmentClass ctx => CurryAssignmentClass (ctx ::> a) where-  curryAssignment k = curryAssignment (\asgn a -> k (asgn :> a))-  uncurryAssignment k asgn =-    case viewAssign asgn of-      AssignExtend asgn' x -> uncurryAssignment k asgn' x---- | Create an assignment from a list of values.-fromList :: [Some f] -> Some (Assignment f)-fromList = go empty-  where go :: Assignment f ctx -> [Some f] -> Some (Assignment f)-        go prev [] = Some prev-        go prev (Some g:next) = (go $! prev `extend` g) next---newtype Collector m w a = Collector { runCollector :: m w }-instance Functor (Collector m w) where-  fmap _ (Collector x) = Collector x-instance (Applicative m, Monoid w) => Applicative (Collector m w) where-  pure _ = Collector (pure mempty)-  Collector x <*> Collector y = Collector (liftA2 (<>) x y)---- | Visit each of the elements in an @Assignment@ in order---   from left to right and collect the results using the provided @Monoid@.-traverseAndCollect ::-  (Monoid w, Applicative m) =>-  (forall tp. Index ctx tp -> f tp -> m w) ->-  Assignment f ctx ->-  m w-traverseAndCollect f =-  runCollector . traverseWithIndex (\i x -> Collector (f i x))------------------------------------------------------------------------------------- Size and Index values--size1 :: Size (EmptyCtx ::> a)-size1 = incSize zeroSize--size2 :: Size (EmptyCtx ::> a ::> b)-size2 = incSize size1--size3 :: Size (EmptyCtx ::> a ::> b ::> c)-size3 = incSize size2--size4 :: Size (EmptyCtx ::> a ::> b ::> c ::> d)-size4 = incSize size3--size5 :: Size (EmptyCtx ::> a ::> b ::> c ::> d ::> e)-size5 = incSize size4--size6 :: Size (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f)-size6 = incSize size5--i1of2 :: Index (EmptyCtx ::> a ::> b) a-i1of2 = skipIndex baseIndex--i2of2 :: Index (EmptyCtx ::> a ::> b) b-i2of2 = nextIndex size1--i1of3 :: Index (EmptyCtx ::> a ::> b ::> c) a-i1of3 = skipIndex i1of2--i2of3 :: Index (EmptyCtx ::> a ::> b ::> c) b-i2of3 = skipIndex i2of2--i3of3 :: Index (EmptyCtx ::> a ::> b ::> c) c-i3of3 = nextIndex size2--i1of4 :: Index (EmptyCtx ::> a ::> b ::> c ::> d) a-i1of4 = skipIndex i1of3--i2of4 :: Index (EmptyCtx ::> a ::> b ::> c ::> d) b-i2of4 = skipIndex i2of3--i3of4 :: Index (EmptyCtx ::> a ::> b ::> c ::> d) c-i3of4 = skipIndex i3of3--i4of4 :: Index (EmptyCtx ::> a ::> b ::> c ::> d) d-i4of4 = nextIndex size3--i1of5 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e) a-i1of5 = skipIndex i1of4--i2of5 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e) b-i2of5 = skipIndex i2of4--i3of5 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e) c-i3of5 = skipIndex i3of4--i4of5 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e) d-i4of5 = skipIndex i4of4--i5of5 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e) e-i5of5 = nextIndex size4--i1of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) a-i1of6 = skipIndex i1of5--i2of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) b-i2of6 = skipIndex i2of5--i3of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) c-i3of6 = skipIndex i3of5--i4of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) d-i4of6 = skipIndex i4of5--i5of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) e-i5of6 = skipIndex i5of5--i6of6 :: Index (EmptyCtx ::> a ::> b ::> c ::> d ::> e ::> f) f-i6of6 = nextIndex size5
− submodules/parameterized-utils/src/Data/Parameterized/Context/Safe.hs 
@@ -1,994 +0,0 @@---------------------------------------------------------------------------- |--- Module           : Data.Parameterized.Context.Safe--- Copyright        : (c) Galois, Inc 2014-2015--- Maintainer       : Joe Hendrix <jhendrix@galois.com>------ This module defines type contexts as a data-kind that consists of--- a list of types.  Indexes are defined with respect to these contexts.--- In addition, finite dependent products (Assignments) are defined over--- type contexts.  The elements of an assignment can be accessed using--- appropriately-typed indexes.------ This module is intended to export exactly the same API as module--- "Data.Parameterized.Context.Unsafe", so that they can be used--- interchangeably.------ This implementation is entirely typesafe, and provides a proof that--- the signature implemented by this module is consistent.  Contexts,--- indexes, and assignments are represented naively by linear sequences.------ Compared to the implementation in "Data.Parameterized.Context.Unsafe",--- this one suffers from the fact that the operation of extending an--- the context of an index is /not/ a no-op. We therefore cannot use--- 'Data.Coerce.coerce' to understand indexes in a new context without--- actually breaking things.----------------------------------------------------------------------------{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE IncoherentInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeInType #-}-module Data.Parameterized.Context.Safe-  ( module Data.Parameterized.Ctx-    -- * Size-  , Size-  , sizeInt-  , zeroSize-  , incSize-  , decSize-  , extSize-  , addSize-  , SizeView(..)-  , viewSize-  , KnownContext(..)-    -- * Diff-  , Diff-  , noDiff-  , extendRight-  , appendDiff-  , DiffView(..)-  , viewDiff-  , KnownDiff(..)-    -- * Indexing-  , Index-  , indexVal-  , baseIndex-  , skipIndex-  , lastIndex-  , nextIndex-  , extendIndex-  , extendIndex'-  , forIndex-  , forIndexRange-  , intIndex-    -- * Assignments-  , Assignment-  , size-  , Data.Parameterized.Context.Safe.replicate-  , generate-  , generateM-  , empty-  , extend-  , adjust-  , update-  , adjustM-  , AssignView(..)-  , viewAssign-  , (!)-  , (!^)-  , zipWith-  , zipWithM-  , (<++>)-  , traverseWithIndex-  ) where--import qualified Control.Category as Cat-import Control.DeepSeq-import qualified Control.Lens as Lens-import Control.Monad.Identity (Identity(..))-import Data.Hashable-import Data.List (intercalate)-import Data.Maybe (listToMaybe)-import Data.Type.Equality-import Prelude hiding (init, map, null, replicate, succ, zipWith)-import Data.Kind(Type)--#if !MIN_VERSION_base(4,8,0)-import Data.Functor-import Control.Applicative (Applicative(..))-#endif--import Data.Parameterized.Classes-import Data.Parameterized.Ctx-import Data.Parameterized.Some-import Data.Parameterized.TraversableFC----------------------------------------------------------------------------- Size---- | An indexed singleton type representing the size of a context.-data Size (ctx :: Ctx k) where-  SizeZero :: Size 'EmptyCtx-  SizeSucc :: !(Size ctx) -> Size (ctx '::> tp)---- | Convert a context size to an 'Int'.-sizeInt :: Size ctx -> Int-sizeInt SizeZero = 0-sizeInt (SizeSucc sz) = (+1) $! sizeInt sz---- | The size of an empty context.-zeroSize :: Size 'EmptyCtx-zeroSize = SizeZero---- | Increment the size to the next value.-incSize :: Size ctx -> Size (ctx '::> tp)-incSize sz = SizeSucc sz--decSize :: Size (ctx '::> tp) -> Size ctx-decSize (SizeSucc sz) = sz---- | The total size of two concatenated contexts.-addSize :: Size x -> Size y -> Size (x <+> y)-addSize sx SizeZero = sx-addSize sx (SizeSucc sy) = SizeSucc (addSize sx sy)---- | Allows interpreting a size.-data SizeView (ctx :: Ctx k) where-  ZeroSize :: SizeView 'EmptyCtx-  IncSize :: !(Size ctx) -> SizeView (ctx '::> tp)---- | View a size as either zero or a smaller size plus one.-viewSize :: Size ctx -> SizeView ctx-viewSize SizeZero = ZeroSize-viewSize (SizeSucc s) = IncSize s----------------------------------------------------------------------------- Size---- | A context that can be determined statically at compiler time.-class KnownContext (ctx :: Ctx k) where-  knownSize :: Size ctx--instance KnownContext 'EmptyCtx where-  knownSize = zeroSize--instance KnownContext ctx => KnownContext (ctx '::> tp) where-  knownSize = incSize knownSize----------------------------------------------------------------------------- Diff---- | Difference in number of elements between two contexts.--- The first context must be a sub-context of the other.-data Diff (l :: Ctx k) (r :: Ctx k) where-  DiffHere :: Diff ctx ctx-  DiffThere :: Diff ctx1 ctx2 -> Diff ctx1 (ctx2 '::> tp)---- | The identity difference.-noDiff :: Diff l l-noDiff = DiffHere---- | Extend the difference to a sub-context of the right side.-extendRight :: Diff l r -> Diff l (r '::> tp)-extendRight diff = DiffThere diff--appendDiff :: Size r -> Diff l (l <+> r)-appendDiff SizeZero = DiffHere-appendDiff (SizeSucc sz) = DiffThere (appendDiff sz)--composeDiff :: Diff a b -> Diff b c -> Diff a c-composeDiff x DiffHere = x-composeDiff x (DiffThere y) = DiffThere (composeDiff x y)--instance Cat.Category Diff where-  id = DiffHere-  d1 . d2 = composeDiff d2 d1---- | Extend the size by a given difference.-extSize :: Size l -> Diff l r -> Size r-extSize sz DiffHere = sz-extSize sz (DiffThere diff) = incSize (extSize sz diff)--data DiffView a b where-  NoDiff :: DiffView a a-  ExtendRightDiff :: Diff a b -> DiffView a (b ::> r)--viewDiff :: Diff a b -> DiffView a b-viewDiff DiffHere = NoDiff-viewDiff (DiffThere diff) = ExtendRightDiff diff----------------------------------------------------------------------------- KnownDiff---- | A difference that can be automatically inferred at compile time.-class KnownDiff (l :: Ctx k) (r :: Ctx k) where-  knownDiff :: Diff l r--instance KnownDiff l l where-  knownDiff = noDiff--instance KnownDiff l r => KnownDiff l (r '::> tp) where-  knownDiff = extendRight knownDiff----------------------------------------------------------------------------- Index---- | An index is a reference to a position with a particular type in a--- context.-data Index (ctx :: Ctx k) (tp :: k) where-  IndexHere :: Size ctx -> Index (ctx '::> tp) tp-  IndexThere :: !(Index ctx tp) -> Index (ctx '::> tp') tp---- | Convert an index to an 'Int', where the index of the left-most type in the context is 0.-indexVal :: Index ctx tp -> Int-indexVal (IndexHere sz) = sizeInt sz-indexVal (IndexThere idx) = indexVal idx--instance Eq (Index ctx tp) where-  idx1 == idx2 = isJust (testEquality idx1 idx2)--instance TestEquality (Index ctx) where-  testEquality (IndexHere _) (IndexHere _) = Just Refl-  testEquality (IndexHere _) (IndexThere _) = Nothing-  testEquality (IndexThere _) (IndexHere _) = Nothing-  testEquality (IndexThere idx1) (IndexThere idx2) =-     case testEquality idx1 idx2 of-         Just Refl -> Just Refl-         Nothing -> Nothing--instance Ord (Index ctx tp) where-  compare i j = toOrdering (compareF i j)--instance OrdF (Index ctx) where-  compareF (IndexHere _) (IndexHere _) = EQF-  compareF (IndexThere _) (IndexHere _) = LTF-  compareF (IndexHere _) (IndexThere _) = GTF-  compareF (IndexThere idx1) (IndexThere idx2) = lexCompareF idx1 idx2 $ EQF---- | Index for first element in context.-baseIndex :: Index ('EmptyCtx '::> tp) tp-baseIndex = IndexHere SizeZero---- | Increase context while staying at same index.-skipIndex :: Index ctx x -> Index (ctx '::> y) x-skipIndex idx = IndexThere idx---- | Return the index of an element one past the size.-nextIndex :: Size ctx -> Index (ctx '::> tp) tp-nextIndex sz = IndexHere sz---- | Return the last index of a element.-lastIndex :: Size (ctx ::> tp) -> Index (ctx ::> tp) tp-lastIndex (SizeSucc s) = IndexHere s--{-# INLINE extendIndex #-}-extendIndex :: KnownDiff l r => Index l tp -> Index r tp-extendIndex = extendIndex' knownDiff--{-# INLINE extendIndex' #-}-extendIndex' :: Diff l r -> Index l tp -> Index r tp-extendIndex' DiffHere idx = idx-extendIndex' (DiffThere diff) idx = IndexThere (extendIndex' diff idx)---- | Given a size @n@, an initial value @v0@, and a function @f@,--- @forIndex n v0 f@ calls @f@ on each index less than @n@ starting--- from @0@ and @v0@, with the value @v@ obtained from the last call.-forIndex :: forall ctx r-          . Size ctx-         -> (forall tp . r -> Index ctx tp -> r)-         -> r-         -> r-forIndex sz_top f = go id sz_top- where go :: forall ctx'. (forall tp. Index ctx' tp -> Index ctx tp) -> Size ctx' -> r -> r-       go _ SizeZero = id-       go g (SizeSucc sz) = \r -> go (\i -> g (IndexThere i)) sz  $ f r (g (IndexHere sz))--data LDiff (l :: Ctx k) (r :: Ctx k) where- LDiffHere :: LDiff a a- LDiffThere :: !(LDiff (a::>x) b) -> LDiff a b--ldiffIndex :: Index a tp -> LDiff a b -> Index b tp-ldiffIndex i LDiffHere = i-ldiffIndex i (LDiffThere d) = ldiffIndex (IndexThere i) d--forIndexLDiff :: Size a-              -> LDiff a b-              -> (forall tp . Index b tp -> r -> r)-              -> r-              -> r-forIndexLDiff _ LDiffHere _ r = r-forIndexLDiff sz (LDiffThere d) f r =-  forIndexLDiff (SizeSucc sz) d f (f (ldiffIndex (IndexHere sz) d) r)--forIndexRangeImpl :: Int-                  -> Size a-                  -> LDiff a b-                  -> (forall tp . Index b tp -> r -> r)-                  -> r-                  -> r-forIndexRangeImpl 0 sz d f r = forIndexLDiff sz d f r-forIndexRangeImpl _ SizeZero _ _ r = r-forIndexRangeImpl i (SizeSucc sz) d f r =-  forIndexRangeImpl (i-1) sz (LDiffThere d) f r---- | Given an index 'i', size 'n', a function 'f', value 'v', and a function 'f',--- 'forIndex i n f v' is equivalent to 'v' when 'i >= sizeInt n', and--- 'f i (forIndexRange (i+1) n v0)' otherwise.-forIndexRange :: Int-              -> Size ctx-              -> (forall tp . Index ctx tp -> r -> r)-              -> r-              -> r-forIndexRange i sz f r = forIndexRangeImpl i sz LDiffHere f r--indexList :: forall ctx. Size ctx -> [Some (Index ctx)]-indexList sz_top = go id [] sz_top- where go :: (forall tp. Index ctx' tp -> Index ctx tp)-          -> [Some (Index ctx)]-          -> Size ctx'-          -> [Some (Index ctx)]-       go _ ls SizeZero       = ls-       go g ls (SizeSucc sz)  = go (\i -> g (IndexThere i)) (Some (g (IndexHere sz)) : ls) sz---- | Return index at given integer or nothing if integer is out of bounds.-intIndex :: Int -> Size ctx -> Maybe (Some (Index ctx))-intIndex n sz = listToMaybe $ drop n $ indexList sz--instance Show (Index ctx tp) where-   show = show . indexVal--instance ShowF (Index ctx)----------------------------------------------------------------------------- Assignment---- | An assignment is a sequence that maps each index with type 'tp' to--- a value of type 'f tp'.-data Assignment (f :: k -> Type) (ctx :: Ctx k) where-  AssignmentEmpty :: Assignment f EmptyCtx-  AssignmentExtend :: Assignment f ctx -> f tp -> Assignment f (ctx ::> tp)---- | View an assignment as either empty or an assignment with one appended.-data AssignView (f :: k -> Type) (ctx :: Ctx k) where-  AssignEmpty :: AssignView f EmptyCtx-  AssignExtend :: Assignment f ctx -> f tp -> AssignView f (ctx::>tp)--viewAssign :: forall f ctx . Assignment f ctx -> AssignView f ctx-viewAssign AssignmentEmpty = AssignEmpty-viewAssign (AssignmentExtend asgn x) = AssignExtend asgn x--instance NFData (Assignment f ctx) where-  rnf AssignmentEmpty = ()-  rnf (AssignmentExtend asgn x) = rnf asgn `seq` x `seq` ()---- | Return number of elements in assignment.-size :: Assignment f ctx -> Size ctx-size AssignmentEmpty = SizeZero-size (AssignmentExtend asgn _) = SizeSucc (size asgn)---- | Generate an assignment-generate :: forall ctx f-          . Size ctx-         -> (forall tp . Index ctx tp -> f tp)-         -> Assignment f ctx-generate sz_top f = go id sz_top- where go :: forall ctx'-           . (forall tp. Index ctx' tp -> Index ctx tp)-          -> Size ctx'-          -> Assignment f ctx'-       go _ SizeZero = AssignmentEmpty-       go g (SizeSucc sz) =-            let ctx = go (\i -> g (IndexThere i)) sz-                x = f (g (IndexHere sz))-             in AssignmentExtend ctx x---- | Generate an assignment-generateM :: forall ctx m f-           . Applicative m-          => Size ctx-          -> (forall tp . Index ctx tp -> m (f tp))-          -> m (Assignment f ctx)-generateM sz_top f = go id sz_top- where go :: forall ctx'. (forall tp. Index ctx' tp -> Index ctx tp) -> Size ctx' -> m (Assignment f ctx')-       go _ SizeZero = pure AssignmentEmpty-       go g (SizeSucc sz) =-             AssignmentExtend <$> (go (\i -> g (IndexThere i)) sz) <*> f (g (IndexHere sz))---- | @replicate n@ make a context with different copies of the same--- polymorphic value.-replicate :: Size ctx -> (forall tp . f tp) -> Assignment f ctx-replicate n c = generate n (\_ -> c)---- | Create empty indexec vector.-empty :: Assignment f 'EmptyCtx-empty = AssignmentEmpty--extend :: Assignment f ctx -> f tp -> Assignment f (ctx '::> tp)-extend asgn e = AssignmentExtend asgn e--{-# DEPRECATED adjust "Replace 'adjust f i asgn' with 'Lens.over (ixF i) f asgn' instead." #-}-adjust :: forall f ctx tp. (f tp -> f tp) -> Index ctx tp -> Assignment f ctx -> Assignment f ctx-adjust f idx asgn = runIdentity (adjustM (Identity . f) idx asgn)--{-# DEPRECATED update "Replace 'update idx val asgn' with 'Lens.set (ixF idx) val asgn' instead." #-}-update :: forall f ctx tp. Index ctx tp -> f tp -> Assignment f ctx -> Assignment f ctx-update i v a = adjust (\_ -> v) i a--adjustM :: forall m f ctx tp. Functor m => (f tp -> m (f tp)) -> Index ctx tp -> Assignment f ctx -> m (Assignment f ctx)-adjustM f = go (\x -> x)- where-  go :: (forall tp'. g tp' -> f tp') -> Index ctx' tp -> Assignment g ctx' -> m (Assignment f ctx')-  go g (IndexHere _)     (AssignmentExtend asgn x) = AssignmentExtend (map g asgn) <$> f (g x)-  go g (IndexThere idx)  (AssignmentExtend asgn x) = flip AssignmentExtend (g x)   <$> go g idx asgn-#if !MIN_VERSION_base(4,9,0)--- GHC 7.10.3 and early does not recognize that the above definition is complete,--- and so need the equation below.  GHC 8.0.1 does not require the additional--- equation.-  go _ _ _ = error "SafeTypeContext.adjustM: impossible!"-#endif--type instance IndexF   (Assignment (f :: k -> Type) ctx) = Index ctx-type instance IxValueF (Assignment (f :: k -> Type) ctx) = f--instance forall (f :: k -> Type) ctx. IxedF k (Assignment f ctx) where-  ixF :: Index ctx x -> Lens.Lens' (Assignment f ctx) (f x)-  ixF idx f = adjustM f idx--instance forall (f :: k -> Type) ctx. IxedF' k (Assignment f ctx) where-  ixF' :: Index ctx x -> Lens.Lens' (Assignment f ctx) (f x)-  ixF' idx f = adjustM f idx--idxlookup :: (forall tp. a tp -> b tp) -> Assignment a ctx -> forall tp. Index ctx tp -> b tp-idxlookup f (AssignmentExtend _   x) (IndexHere _) = f x-idxlookup f (AssignmentExtend ctx _) (IndexThere idx) = idxlookup f ctx idx-idxlookup _ AssignmentEmpty _ = error "Data.Parameterized.Context.Safe.lookup: impossible case"---- | Return value of assignment.-(!) :: Assignment f ctx -> Index ctx tp -> f tp-(!) asgn idx = idxlookup id asgn idx---- | Return value of assignment, where the index is into an---   initial sequence of the assignment.-(!^) :: KnownDiff l r => Assignment f r -> Index l tp -> f tp-a !^ i = a ! extendIndex i--instance TestEquality f => Eq (Assignment f ctx) where-  x == y = isJust (testEquality x y)--testEq :: (forall x y. f x -> f y -> Maybe (x :~: y))-       -> Assignment f cxt1 -> Assignment f cxt2 -> Maybe (cxt1 :~: cxt2)-testEq _ AssignmentEmpty AssignmentEmpty = Just Refl-testEq test (AssignmentExtend ctx1 x1) (AssignmentExtend ctx2 x2) =-     case testEq test ctx1 ctx2 of-       Nothing -> Nothing-       Just Refl ->-          case test x1 x2 of-             Nothing -> Nothing-             Just Refl -> Just Refl-testEq _ AssignmentEmpty AssignmentExtend{} = Nothing-testEq _ AssignmentExtend{} AssignmentEmpty = Nothing--instance TestEqualityFC Assignment where-   testEqualityFC = testEq-instance TestEquality f => TestEquality (Assignment f) where-   testEquality x y = testEq testEquality x y-instance TestEquality f => PolyEq (Assignment f x) (Assignment f y) where-  polyEqF x y = fmap (\Refl -> Refl) $ testEquality x y--compareAsgn :: (forall x y. f x -> f y -> OrderingF x y)-            -> Assignment f ctx1 -> Assignment f ctx2 -> OrderingF ctx1 ctx2-compareAsgn _ AssignmentEmpty AssignmentEmpty = EQF-compareAsgn _ AssignmentEmpty _ = GTF-compareAsgn _ _ AssignmentEmpty = LTF-compareAsgn test (AssignmentExtend ctx1 x) (AssignmentExtend ctx2 y) =-  case compareAsgn test ctx1 ctx2 of-    LTF -> LTF-    GTF -> GTF-    EQF -> case test x y of-              LTF -> LTF-              GTF -> GTF-              EQF -> EQF--instance OrdFC Assignment where-  compareFC = compareAsgn--instance OrdF f => OrdF (Assignment f) where-  compareF = compareAsgn compareF--instance OrdF f => Ord (Assignment f ctx) where-  compare x y = toOrdering (compareF x y)---instance Hashable (Index ctx tp) where-  hashWithSalt = hashWithSaltF-instance HashableF (Index ctx) where-  hashWithSaltF s i = hashWithSalt s (indexVal i)--instance HashableF f => HashableF (Assignment f) where-  hashWithSaltF = hashWithSalt--instance HashableF f => Hashable (Assignment f ctx) where-  hashWithSalt s AssignmentEmpty = s-  hashWithSalt s (AssignmentExtend asgn x) = (s `hashWithSalt` asgn) `hashWithSaltF` x--instance ShowF f => Show (Assignment f ctx) where-  show a = "[" ++ intercalate ", " (toList showF a) ++ "]"--instance ShowF f => ShowF (Assignment f)--instance FunctorFC Assignment where-  fmapFC = fmapFCDefault--instance FoldableFC Assignment where-  foldMapFC = foldMapFCDefault--instance TraversableFC Assignment where-  traverseFC = traverseF---- | Map assignment-map :: (forall tp . f tp -> g tp) -> Assignment f c -> Assignment g c-map = fmapFC--traverseF :: forall (f:: k -> Type) (g::k -> Type) (m:: Type -> Type) (c::Ctx k)-           . Applicative m-          => (forall tp . f tp -> m (g tp))-          -> Assignment f c-          -> m (Assignment g c)-traverseF _ AssignmentEmpty = pure AssignmentEmpty-traverseF f (AssignmentExtend asgn x) = pure AssignmentExtend <*> traverseF f asgn <*> f x---- | Convert assignment to list.-toList :: (forall tp . f tp -> a)-       -> Assignment f c-       -> [a]-toList = toListFC--zipWithM :: Applicative m-         => (forall tp . f tp -> g tp -> m (h tp))-         -> Assignment f c-         -> Assignment g c-         -> m (Assignment h c)-zipWithM f x y = go x y- where go AssignmentEmpty AssignmentEmpty = pure AssignmentEmpty-       go (AssignmentExtend asgn1 x1) (AssignmentExtend asgn2 x2) =-             AssignmentExtend <$> (zipWithM f asgn1 asgn2) <*> (f x1 x2)--zipWith :: (forall x . f x -> g x -> h x)-        -> Assignment f a-        -> Assignment g a-        -> Assignment h a-zipWith f = \x y -> runIdentity $ zipWithM (\u v -> pure (f u v)) x y-{-# INLINE zipWith #-}--traverseWithIndex :: Applicative m-                  => (forall tp . Index ctx tp -> f tp -> m (g tp))-                  -> Assignment f ctx-                  -> m (Assignment g ctx)-traverseWithIndex f a = generateM (size a) $ \i -> f i (a ! i)--(<++>) :: Assignment f x -> Assignment f y -> Assignment f (x <+> y)-x <++> AssignmentEmpty = x-x <++> AssignmentExtend y t = AssignmentExtend (x <++> y) t----------------------------------------------------------------------------- KnownRepr instances--instance (KnownRepr (Assignment f) ctx, KnownRepr f bt)-      => KnownRepr (Assignment f) (ctx ::> bt) where-  knownRepr = knownRepr `extend` knownRepr--instance KnownRepr (Assignment f) EmptyCtx where-  knownRepr = empty------------------------------------------------------------------------------------------- lookups and update for lenses--data MyNat where-  MyZ :: MyNat-  MyS :: MyNat -> MyNat--type MyZ = 'MyZ-type MyS = 'MyS--data MyNatRepr :: MyNat -> Type where-  MyZR :: MyNatRepr MyZ-  MySR :: MyNatRepr n -> MyNatRepr (MyS n)--type family StrongCtxUpdate (n::MyNat) (ctx::Ctx k) (z::k) :: Ctx k where-  StrongCtxUpdate n       EmptyCtx     z = EmptyCtx-  StrongCtxUpdate MyZ     (ctx::>x)    z = ctx ::> z-  StrongCtxUpdate (MyS n) (ctx::>x)    z = (StrongCtxUpdate n ctx z) ::> x--type family MyNatLookup (n::MyNat) (ctx::Ctx k) (f::k -> Type) :: Type where-  MyNatLookup n       EmptyCtx  f = ()-  MyNatLookup MyZ     (ctx::>x) f = f x-  MyNatLookup (MyS n) (ctx::>x) f = MyNatLookup n ctx f--mynat_lookup :: MyNatRepr n -> Assignment f ctx -> MyNatLookup n ctx f-mynat_lookup _   AssignmentEmpty = ()-mynat_lookup MyZR     (AssignmentExtend _    x) = x-mynat_lookup (MySR n) (AssignmentExtend asgn _) = mynat_lookup n asgn--strong_ctx_update :: MyNatRepr n -> Assignment f ctx -> f tp -> Assignment f (StrongCtxUpdate n ctx tp)-strong_ctx_update _        AssignmentEmpty           _ = AssignmentEmpty-strong_ctx_update MyZR     (AssignmentExtend asgn _) z = AssignmentExtend asgn z-strong_ctx_update (MySR n) (AssignmentExtend asgn x) z = AssignmentExtend (strong_ctx_update n asgn z) x----------------------------------------------------------------------------- 1 field lens combinators--type Assignment1 f x1 = Assignment f ('EmptyCtx '::> x1)--instance Lens.Field1 (Assignment1 f t) (Assignment1 f u) (f t) (f u) where--  _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MyZR----------------------------------------------------------------------------- 2 field lens combinators--type Assignment2 f x1 x2-   = Assignment f ('EmptyCtx '::> x1 '::> x2)--instance Lens.Field1 (Assignment2 f t x2) (Assignment2 f u x2) (f t) (f u) where-  _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MyZR--instance Lens.Field2 (Assignment2 f x1 t) (Assignment2 f x1 u) (f t) (f u) where-  _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MyZR------------------------------------------------------------------------------ 3 field lens combinators--type Assignment3 f x1 x2 x3-   = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3)--instance Lens.Field1 (Assignment3 f t x2 x3)-                     (Assignment3 f u x2 x3)-                     (f t)-                     (f u) where-  _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MyZR--instance Lens.Field2 (Assignment3 f x1 t x3)-                     (Assignment3 f x1 u x3)-                     (f t)-                     (f u) where-  _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MyZR--instance Lens.Field3 (Assignment3 f x1 x2 t)-                     (Assignment3 f x1 x2 u)-                     (f t)-                     (f u) where-  _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MyZR----------------------------------------------------------------------------- 4 field lens combinators--type Assignment4 f x1 x2 x3 x4-   = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4)--instance Lens.Field1 (Assignment4 f t x2 x3 x4)-                     (Assignment4 f u x2 x3 x4)-                     (f t)-                     (f u) where-  _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MyZR--instance Lens.Field2 (Assignment4 f x1 t x3 x4)-                     (Assignment4 f x1 u x3 x4)-                     (f t)-                     (f u) where-  _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MyZR--instance Lens.Field3 (Assignment4 f x1 x2 t x4)-                     (Assignment4 f x1 x2 u x4)-                     (f t)-                     (f u) where-  _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MyZR--instance Lens.Field4 (Assignment4 f x1 x2 x3 t)-                     (Assignment4 f x1 x2 x3 u)-                     (f t)-                     (f u) where-  _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MyZR------------------------------------------------------------------------------ 5 field lens combinators--type Assignment5 f x1 x2 x3 x4 x5-   = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5)--instance Lens.Field1 (Assignment5 f t x2 x3 x4 x5)-                     (Assignment5 f u x2 x3 x4 x5)-                     (f t)-                     (f u) where-  _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MySR $ MyZR--instance Lens.Field2 (Assignment5 f x1 t x3 x4 x5)-                     (Assignment5 f x1 u x3 x4 x5)-                     (f t)-                     (f u) where-  _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MyZR--instance Lens.Field3 (Assignment5 f x1 x2 t x4 x5)-                     (Assignment5 f x1 x2 u x4 x5)-                     (f t)-                     (f u) where-  _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MyZR--instance Lens.Field4 (Assignment5 f x1 x2 x3 t x5)-                     (Assignment5 f x1 x2 x3 u x5)-                     (f t)-                     (f u) where-  _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MyZR--instance Lens.Field5 (Assignment5 f x1 x2 x3 x4 t)-                     (Assignment5 f x1 x2 x3 x4 u)-                     (f t)-                     (f u) where-  _5 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MyZR----------------------------------------------------------------------------- 6 field lens combinators--type Assignment6 f x1 x2 x3 x4 x5 x6-   = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6)--instance Lens.Field1 (Assignment6 f t x2 x3 x4 x5 x6)-                     (Assignment6 f u x2 x3 x4 x5 x6)-                     (f t)-                     (f u) where-  _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MySR $ MySR $ MyZR--instance Lens.Field2 (Assignment6 f x1 t x3 x4 x5 x6)-                     (Assignment6 f x1 u x3 x4 x5 x6)-                     (f t)-                     (f u) where-  _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MySR $ MyZR--instance Lens.Field3 (Assignment6 f x1 x2 t x4 x5 x6)-                     (Assignment6 f x1 x2 u x4 x5 x6)-                     (f t)-                     (f u) where-  _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MyZR--instance Lens.Field4 (Assignment6 f x1 x2 x3 t x5 x6)-                     (Assignment6 f x1 x2 x3 u x5 x6)-                     (f t)-                     (f u) where-  _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MyZR--instance Lens.Field5 (Assignment6 f x1 x2 x3 x4 t x6)-                     (Assignment6 f x1 x2 x3 x4 u x6)-                     (f t)-                     (f u) where-  _5 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MyZR--instance Lens.Field6 (Assignment6 f x1 x2 x3 x4 x5 t)-                     (Assignment6 f x1 x2 x3 x4 x5 u)-                     (f t)-                     (f u) where-  _6 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MyZR----------------------------------------------------------------------------- 7 field lens combinators--type Assignment7 f x1 x2 x3 x4 x5 x6 x7-   = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6 '::> x7)--instance Lens.Field1 (Assignment7 f t x2 x3 x4 x5 x6 x7)-                     (Assignment7 f u x2 x3 x4 x5 x6 x7)-                     (f t)-                     (f u) where-  _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR--instance Lens.Field2 (Assignment7 f x1 t x3 x4 x5 x6 x7)-                     (Assignment7 f x1 u x3 x4 x5 x6 x7)-                     (f t)-                     (f u) where-  _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MySR $ MySR $ MyZR--instance Lens.Field3 (Assignment7 f x1 x2 t x4 x5 x6 x7)-                     (Assignment7 f x1 x2 u x4 x5 x6 x7)-                     (f t)-                     (f u) where-  _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MySR $ MyZR--instance Lens.Field4 (Assignment7 f x1 x2 x3 t x5 x6 x7)-                     (Assignment7 f x1 x2 x3 u x5 x6 x7)-                     (f t)-                     (f u) where-  _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MyZR--instance Lens.Field5 (Assignment7 f x1 x2 x3 x4 t x6 x7)-                     (Assignment7 f x1 x2 x3 x4 u x6 x7)-                     (f t)-                     (f u) where-  _5 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MyZR--instance Lens.Field6 (Assignment7 f x1 x2 x3 x4 x5 t x7)-                     (Assignment7 f x1 x2 x3 x4 x5 u x7)-                     (f t)-                     (f u) where-  _6 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MyZR--instance Lens.Field7 (Assignment7 f x1 x2 x3 x4 x5 x6 t)-                     (Assignment7 f x1 x2 x3 x4 x5 x6 u)-                     (f t)-                     (f u) where-  _7 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MyZR----------------------------------------------------------------------------- 8 field lens combinators--type Assignment8 f x1 x2 x3 x4 x5 x6 x7 x8-   = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6 '::> x7 '::> x8)--instance Lens.Field1 (Assignment8 f t x2 x3 x4 x5 x6 x7 x8)-                     (Assignment8 f u x2 x3 x4 x5 x6 x7 x8)-                     (f t)-                     (f u) where-  _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR---instance Lens.Field2 (Assignment8 f x1 t x3 x4 x5 x6 x7 x8)-                     (Assignment8 f x1 u x3 x4 x5 x6 x7 x8)-                     (f t)-                     (f u) where-  _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR--instance Lens.Field3 (Assignment8 f x1 x2 t x4 x5 x6 x7 x8)-                     (Assignment8 f x1 x2 u x4 x5 x6 x7 x8)-                     (f t)-                     (f u) where-  _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MySR $ MySR $ MyZR--instance Lens.Field4 (Assignment8 f x1 x2 x3 t x5 x6 x7 x8)-                     (Assignment8 f x1 x2 x3 u x5 x6 x7 x8)-                     (f t)-                     (f u) where-  _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MySR $ MyZR--instance Lens.Field5 (Assignment8 f x1 x2 x3 x4 t x6 x7 x8)-                     (Assignment8 f x1 x2 x3 x4 u x6 x7 x8)-                     (f t)-                     (f u) where-  _5 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MyZR--instance Lens.Field6 (Assignment8 f x1 x2 x3 x4 x5 t x7 x8)-                     (Assignment8 f x1 x2 x3 x4 x5 u x7 x8)-                     (f t)-                     (f u) where-  _6 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MyZR--instance Lens.Field7 (Assignment8 f x1 x2 x3 x4 x5 x6 t x8)-                     (Assignment8 f x1 x2 x3 x4 x5 x6 u x8)-                     (f t)-                     (f u) where-  _7 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MyZR--instance Lens.Field8 (Assignment8 f x1 x2 x3 x4 x5 x6 x7 t)-                     (Assignment8 f x1 x2 x3 x4 x5 x6 x7 u)-                     (f t)-                     (f u) where-  _8 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MyZR----------------------------------------------------------------------------- 9 field lens combinators--type Assignment9 f x1 x2 x3 x4 x5 x6 x7 x8 x9-   = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6 '::> x7 '::> x8 '::> x9)---instance Lens.Field1 (Assignment9 f t x2 x3 x4 x5 x6 x7 x8 x9)-                     (Assignment9 f u x2 x3 x4 x5 x6 x7 x8 x9)-                     (f t)-                     (f u) where-  _1 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR--instance Lens.Field2 (Assignment9 f x1 t x3 x4 x5 x6 x7 x8 x9)-                     (Assignment9 f x1 u x3 x4 x5 x6 x7 x8 x9)-                     (f t)-                     (f u) where-  _2 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR--instance Lens.Field3 (Assignment9 f x1 x2 t x4 x5 x6 x7 x8 x9)-                     (Assignment9 f x1 x2 u x4 x5 x6 x7 x8 x9)-                     (f t)-                     (f u) where-  _3 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MySR $ MySR $ MySR $ MyZR--instance Lens.Field4 (Assignment9 f x1 x2 x3 t x5 x6 x7 x8 x9)-                     (Assignment9 f x1 x2 x3 u x5 x6 x7 x8 x9)-                     (f t)-                     (f u) where-  _4 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MySR $ MySR $ MyZR--instance Lens.Field5 (Assignment9 f x1 x2 x3 x4 t x6 x7 x8 x9)-                     (Assignment9 f x1 x2 x3 x4 u x6 x7 x8 x9)-                     (f t)-                     (f u) where-  _5 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MySR $ MyZR--instance Lens.Field6 (Assignment9 f x1 x2 x3 x4 x5 t x7 x8 x9)-                     (Assignment9 f x1 x2 x3 x4 x5 u x7 x8 x9)-                     (f t)-                     (f u) where-  _6 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MySR $ MyZR--instance Lens.Field7 (Assignment9 f x1 x2 x3 x4 x5 x6 t x8 x9)-                     (Assignment9 f x1 x2 x3 x4 x5 x6 u x8 x9)-                     (f t)-                     (f u) where-  _7 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MySR $ MyZR--instance Lens.Field8 (Assignment9 f x1 x2 x3 x4 x5 x6 x7 t x9)-                     (Assignment9 f x1 x2 x3 x4 x5 x6 x7 u x9)-                     (f t)-                     (f u) where-  _8 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MySR $ MyZR--instance Lens.Field9 (Assignment9 f x1 x2 x3 x4 x5 x6 x7 x8 t)-                     (Assignment9 f x1 x2 x3 x4 x5 x6 x7 x8 u)-                     (f t)-                     (f u) where-  _9 = Lens.lens (mynat_lookup n) (strong_ctx_update n)-        where n = MyZR
− submodules/parameterized-utils/src/Data/Parameterized/Context/Unsafe.hs 
@@ -1,1223 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeInType #-}-module Data.Parameterized.Context.Unsafe-  ( module Data.Parameterized.Ctx-  , KnownContext(..)-    -- * Size-  , Size-  , sizeInt-  , zeroSize-  , incSize-  , decSize-  , extSize-  , addSize-  , SizeView(..)-  , viewSize-    -- * Diff-  , Diff-  , noDiff-  , extendRight-  , appendDiff-  , DiffView(..)-  , viewDiff-  , KnownDiff(..)-    -- * Indexing-  , Index-  , indexVal-  , baseIndex-  , skipIndex-  , lastIndex-  , nextIndex-  , extendIndex-  , extendIndex'-  , forIndex-  , forIndexRange-  , intIndex-    -- ** IndexRange-  , IndexRange-  , allRange-  , indexOfRange-  , dropHeadRange-  , dropTailRange-    -- * Assignments-  , Assignment-  , size-  , Data.Parameterized.Context.Unsafe.replicate-  , generate-  , generateM-  , empty-  , extend-  , adjust-  , update-  , adjustM-  , AssignView(..)-  , viewAssign-  , (!)-  , (!^)-  , Data.Parameterized.Context.Unsafe.zipWith-  , zipWithM-  , (<++>)-  , traverseWithIndex-  ) where--import qualified Control.Category as Cat-import           Control.DeepSeq-import           Control.Exception-import qualified Control.Lens as Lens-import           Control.Monad.Identity (Identity(..))-import           Data.Bits-import           Data.Coerce-import           Data.Hashable-import           Data.List (intercalate)-import           Data.Proxy-import           Unsafe.Coerce-import           Data.Kind(Type)--import           Data.Parameterized.Classes-import           Data.Parameterized.Ctx-import           Data.Parameterized.Ctx.Proofs-import           Data.Parameterized.Some-import           Data.Parameterized.TraversableFC----------------------------------------------------------------------------- Size---- | Represents the size of a context.-newtype Size (ctx :: Ctx k) = Size Int--type role Size nominal---- | Convert a context size to an 'Int'.-sizeInt :: Size ctx -> Int-sizeInt (Size n) = n---- | The size of an empty context.-zeroSize :: Size 'EmptyCtx-zeroSize = Size 0---- | Increment the size to the next value.-incSize :: Size ctx -> Size (ctx '::> tp)-incSize (Size n) = Size (n+1)--decSize :: Size (ctx '::> tp) -> Size ctx-decSize (Size n) = assert (n > 0) (Size (n-1))---- | Allows interpreting a size.-data SizeView (ctx :: Ctx k) where-  ZeroSize :: SizeView 'EmptyCtx-  IncSize :: !(Size ctx) -> SizeView (ctx '::> tp)---- | Project a size-viewSize :: Size ctx -> SizeView ctx-viewSize (Size 0) = unsafeCoerce ZeroSize-viewSize (Size n) = assert (n > 0) (unsafeCoerce (IncSize (Size (n-1))))--instance Show (Size ctx) where-  show (Size i) = show i---- | A context that can be determined statically at compiler time.-class KnownContext (ctx :: Ctx k) where-  knownSize :: Size ctx--instance KnownContext 'EmptyCtx where-  knownSize = zeroSize--instance KnownContext ctx => KnownContext (ctx '::> tp) where-  knownSize = incSize knownSize----------------------------------------------------------------------------- Diff---- | Difference in number of elements between two contexts.--- The first context must be a sub-context of the other.-newtype Diff (l :: Ctx k) (r :: Ctx k)-      = Diff { _contextExtSize :: Int }--type role Diff nominal nominal---- | The identity difference.-noDiff :: Diff l l-noDiff = Diff 0---- | Extend the difference to a sub-context of the right side.-extendRight :: Diff l r -> Diff l (r '::> tp)-extendRight (Diff i) = Diff (i+1)--appendDiff :: Size r -> Diff l (l <+> r)-appendDiff (Size r) = Diff r--instance Cat.Category Diff where-  id = Diff 0-  Diff j . Diff i = Diff (i + j)---- | Extend the size by a given difference.-extSize :: Size l -> Diff l r -> Size r-extSize (Size i) (Diff j) = Size (i+j)---- | The total size of two concatenated contexts.-addSize :: Size x -> Size y -> Size (x <+> y)-addSize (Size x) (Size y) = Size (x + y)---data DiffView a b where-  NoDiff :: DiffView a a-  ExtendRightDiff :: Diff a b -> DiffView a (b ::> r)--viewDiff :: Diff a b -> DiffView a b-viewDiff (Diff i)-  | i == 0 = unsafeCoerce NoDiff-  | otherwise  = assert (i > 0) $ unsafeCoerce $ ExtendRightDiff (Diff (i-1))----------------------------------------------------------------------------- KnownDiff---- | A difference that can be automatically inferred at compile time.-class KnownDiff (l :: Ctx k) (r :: Ctx k) where-  knownDiff :: Diff l r--instance KnownDiff l l where-  knownDiff = noDiff--instance {-# INCOHERENT #-} KnownDiff l r => KnownDiff l (r '::> tp) where-  knownDiff = extendRight knownDiff----------------------------------------------------------------------------- Index---- | An index is a reference to a position with a particular type in a--- context.-newtype Index (ctx :: Ctx k) (tp :: k) = Index { indexVal :: Int }--type role Index nominal nominal--instance Eq (Index ctx tp) where-  Index i == Index j = i == j--instance TestEquality (Index ctx) where-  testEquality (Index i) (Index j)-    | i == j = Just (unsafeCoerce Refl)-    | otherwise = Nothing--instance Ord (Index ctx tp) where-  Index i `compare` Index j = compare i j--instance OrdF (Index ctx) where-  compareF (Index i) (Index j)-    | i < j = LTF-    | i == j = unsafeCoerce EQF-    | otherwise = GTF---- | Index for first element in context.-baseIndex :: Index ('EmptyCtx '::> tp) tp-baseIndex = Index 0---- | Increase context while staying at same index.-skipIndex :: Index ctx x -> Index (ctx '::> y) x-skipIndex (Index i) = Index i---- | Return the index of a element one past the size.-nextIndex :: Size ctx -> Index (ctx ::> tp) tp-nextIndex n = Index (sizeInt n)---- | Return the last index of a element.-lastIndex :: Size (ctx ::> tp) -> Index (ctx ::> tp) tp-lastIndex n = Index (sizeInt n - 1)--{-# INLINE extendIndex #-}-extendIndex :: KnownDiff l r => Index l tp -> Index r tp-extendIndex = extendIndex' knownDiff--{-# INLINE extendIndex' #-}-extendIndex' :: Diff l r -> Index l tp -> Index r tp-extendIndex' _ = unsafeCoerce---- | Given a size 'n', an initial value 'v0', and a function 'f', 'forIndex n v0 f'--- is equivalent to 'v0' when 'n' is zero, and 'f (forIndex (n-1) v0) (n-1)' otherwise.-forIndex :: forall ctx r-          . Size ctx-         -> (forall tp . r -> Index ctx tp -> r)-         -> r-         -> r-forIndex n f r =-  case viewSize n of-    ZeroSize -> r-    IncSize p -> f (forIndex p (coerce f) r) (nextIndex p)---- | Given an index 'i', size 'n', a function 'f', value 'v', and a function 'f',--- 'forIndex i n f v' is equivalent to 'v' when 'i >= sizeInt n', and--- 'f i (forIndexRange (i+1) n v0)' otherwise.-forIndexRange :: forall ctx r-               . Int-              -> Size ctx-              -> (forall tp . Index ctx tp -> r -> r)-              -> r-              -> r-forIndexRange i (Size n) f r-  | i >= n = r-  | otherwise = f (Index i) (forIndexRange (i+1) (Size n) f r)---- | Return index at given integer or nothing if integer is out of bounds.-intIndex :: Int -> Size ctx -> Maybe (Some (Index ctx))-intIndex i n | 0 <= i && i < sizeInt n = Just (Some (Index i))-             | otherwise = Nothing--instance Show (Index ctx tp) where-   show = show . indexVal--instance ShowF (Index ctx)----------------------------------------------------------------------------- IndexRange---- | This represents a contiguous range of indices.-data IndexRange (ctx :: Ctx k) (sub :: Ctx k)-   = IndexRange {-# UNPACK #-} !Int-                {-# UNPACK #-} !Int---- | Return a range containing all indices in the context.-allRange :: Size ctx -> IndexRange ctx ctx-allRange (Size n) = IndexRange 0 n---- | `indexOfRange` returns the only index in a range.-indexOfRange :: IndexRange ctx (EmptyCtx ::> e) -> Index ctx e-indexOfRange (IndexRange i n) = assert (n == 1) $ Index i---- | `dropTailRange r n` drops the last `n` elements in `r`.-dropTailRange :: IndexRange ctx (x <+> y) -> Size y -> IndexRange ctx x-dropTailRange (IndexRange i n) (Size j) = assert (n >= j) $ IndexRange i (n - j)---- | `dropHeadRange r n` drops the first `n` elements in `r`.-dropHeadRange :: IndexRange ctx (x <+> y) -> Size x -> IndexRange ctx y-dropHeadRange (IndexRange i n) (Size j) = assert (i' >= i && n >= j) $ IndexRange i' (n - j)-  where i' = i + j----------------------------------------------------------------------------- Height--data Height = Zero | Succ Height--type family Pred (k :: Height) :: Height-type instance Pred ('Succ h) = h----------------------------------------------------------------------------- BalancedTree---- | A balanced tree where all leaves are at the same height.------ The first parameter is the height of the tree.--- The second is the parameterized value.-data BalancedTree h (f :: k -> Type) (p :: Ctx k) where-  BalLeaf :: !(f x) -> BalancedTree 'Zero f (SingleCtx x)-  BalPair :: !(BalancedTree h f x)-          -> !(BalancedTree h f y)-          -> BalancedTree ('Succ h) f (x <+> y)--bal_size :: BalancedTree h f p -> Int-bal_size (BalLeaf _) = 1-bal_size (BalPair x y) = bal_size x + bal_size y---instance TestEqualityFC (BalancedTree h) where-  testEqualityFC test (BalLeaf x) (BalLeaf y) = do-    Refl <- test x y-    return Refl-  testEqualityFC test (BalPair x1 x2) (BalPair y1 y2) = do-    Refl <- testEqualityFC test x1 y1-    Refl <- testEqualityFC test x2 y2-    return Refl-#if !MIN_VERSION_base(4,9,0)-  testEqualityFC _ _ _ = Nothing-#endif--instance OrdFC (BalancedTree h) where-  compareFC test (BalLeaf x) (BalLeaf y) =-    joinOrderingF (test x y) $ EQF-#if !MIN_VERSION_base(4,9,0)-  compareFC _ BalLeaf{} _ = LTF-  compareFC _ _ BalLeaf{} = GTF-#endif-  compareFC test (BalPair x1 x2) (BalPair y1 y2) =-    joinOrderingF (compareFC test x1 y1) $-    joinOrderingF (compareFC test x2 y2) $-    EQF--instance HashableF f => HashableF (BalancedTree h f) where-  hashWithSaltF s t =-    case t of-      BalLeaf x -> s `hashWithSaltF` x-      BalPair x y -> s `hashWithSaltF` x `hashWithSaltF` y--fmap_bal :: (forall tp . f tp -> g tp)-         -> BalancedTree h f c-         -> BalancedTree h g c-fmap_bal = go-  where go :: (forall tp . f tp -> g tp)-              -> BalancedTree h f c-              -> BalancedTree h g c-        go f (BalLeaf x) = BalLeaf (f x)-        go f (BalPair x y) = BalPair (go f x) (go f y)-{-# INLINABLE fmap_bal #-}--traverse_bal :: Applicative m-             => (forall tp . f tp -> m (g tp))-             -> BalancedTree h f c-             -> m (BalancedTree h g c)-traverse_bal = go-  where go :: Applicative m-              => (forall tp . f tp -> m (g tp))-              -> BalancedTree h f c-              -> m (BalancedTree h g c)-        go f (BalLeaf x) = BalLeaf <$> f x-        go f (BalPair x y) = BalPair <$> go f x <*> go f y-{-# INLINABLE traverse_bal #-}--instance ShowF f => Show (BalancedTree h f tp) where-  show (BalLeaf x) = showF x-  show (BalPair x y) = "BalPair " Prelude.++ show x Prelude.++ " " Prelude.++ show y--instance ShowF f => ShowF (BalancedTree h f)--unsafe_bal_generate :: forall ctx h f t-                     . Int -- ^ Height of tree to generate-                    -> Int -- ^ Starting offset for entries.-                    -> (forall tp . Index ctx tp -> f tp)-                    -> BalancedTree h f t-unsafe_bal_generate h o f-  | h <  0 = error "unsafe_bal_generate given negative height"-  | h == 0 = unsafeCoerce $ BalLeaf (f (Index o))-  | otherwise =-    let l = unsafe_bal_generate (h-1) o f-        o' = o + 1 `shiftL` (h-1)-        u = assert (o + bal_size l == o') $ unsafe_bal_generate (h-1) o' f-     in unsafeCoerce $ BalPair l u--unsafe_bal_generateM :: forall m ctx h f t-                      . Applicative m-                     => Int -- ^ Height of tree to generate-                     -> Int -- ^ Starting offset for entries.-                     -> (forall x . Index ctx x -> m (f x))-                     -> m (BalancedTree h f t)-unsafe_bal_generateM h o f-  | h == 0 = unsafeCoerce . BalLeaf <$> f (Index o)-  | otherwise =-    let o' = o + 1 `shiftL` (h-1)-        g lv uv = assert (o' == o + bal_size lv) $-           unsafeCoerce (BalPair lv uv)-      in g <$> unsafe_bal_generateM (h-1) o  f-           <*> unsafe_bal_generateM (h-1) o' f---- | Lookup index in tree.-unsafe_bal_index :: BalancedTree h f a -- ^ Tree to lookup.-                 -> Int -- ^ Index to lookup.-                 -> Int  -- ^ Height of tree-                 -> f tp-unsafe_bal_index _ j i-  | seq j $ seq i $ False = error "bad unsafe_bal_index"-unsafe_bal_index (BalLeaf u) _ i = assert (i == 0) $ unsafeCoerce u-unsafe_bal_index (BalPair x y) j i-  | j `testBit` (i-1) = unsafe_bal_index y j $! (i-1)-  | otherwise         = unsafe_bal_index x j $! (i-1)---- | Update value at index in tree.-unsafe_bal_adjust :: Functor m-                  => (f x -> m (f y))-                  -> BalancedTree h f a -- ^ Tree to update-                  -> Int -- ^ Index to lookup.-                  -> Int  -- ^ Height of tree-                  -> m (BalancedTree h f b)-unsafe_bal_adjust f (BalLeaf u) _ i = assert (i == 0) $-  (unsafeCoerce . BalLeaf <$> (f (unsafeCoerce u)))-unsafe_bal_adjust f (BalPair x y) j i-  | j `testBit` (i-1) = (unsafeCoerce . BalPair x      <$> (unsafe_bal_adjust f y j (i-1)))-  | otherwise         = (unsafeCoerce . flip BalPair y <$> (unsafe_bal_adjust f x j (i-1)))--{-# SPECIALIZE unsafe_bal_adjust-     :: (f x -> Identity (f y))-     -> BalancedTree h f a-     -> Int-     -> Int-     -> Identity (BalancedTree h f b)-  #-}---- | Zip two balanced trees together.-bal_zipWithM :: Applicative m-             => (forall x . f x -> g x -> m (h x))-             -> BalancedTree u f a-             -> BalancedTree u g a-             -> m (BalancedTree u h a)-bal_zipWithM f (BalLeaf x) (BalLeaf y) = BalLeaf <$> f x y-bal_zipWithM f (BalPair x1 x2) (BalPair y1 y2) =-  BalPair <$> bal_zipWithM f x1 (unsafeCoerce y1)-          <*> bal_zipWithM f x2 (unsafeCoerce y2)-#if !MIN_VERSION_base(4,9,0)-bal_zipWithM _ _ _ = error "ilegal args to bal_zipWithM"-#endif-{-# INLINABLE bal_zipWithM #-}----------------------------------------------------------------------------- BinomialTree--data BinomialTree (h::Height) (f :: k -> Type) :: Ctx k -> Type where-  Empty :: BinomialTree h f EmptyCtx--  -- Contains size of the subtree, subtree, then element.-  PlusOne  :: !Int-           -> !(BinomialTree ('Succ h) f x)-           -> !(BalancedTree h f y)-           -> BinomialTree h f (x <+> y)--  -- Contains size of the subtree, subtree, then element.-  PlusZero  :: !Int-            -> !(BinomialTree ('Succ h) f x)-            -> BinomialTree h f x--tsize :: BinomialTree h f a -> Int-tsize Empty = 0-tsize (PlusOne s _ _) = 2*s+1-tsize (PlusZero  s _) = 2*s--t_cnt_size :: BinomialTree h f a -> Int-t_cnt_size Empty = 0-t_cnt_size (PlusOne _ l r) = t_cnt_size l + bal_size r-t_cnt_size (PlusZero  _ l) = t_cnt_size l---- | Concatenate a binomial tree and a balanced tree.-append :: BinomialTree h f x-       -> BalancedTree h f y-       -> BinomialTree h f (x <+> y)-append Empty y = PlusOne 0 Empty y-append (PlusOne _ t x) y =-  case assoc t x y of-    Refl ->-      let t' = append t (BalPair x y)-       in PlusZero (tsize t') t'-append (PlusZero s t) x = PlusOne s t x--instance TestEqualityFC (BinomialTree h) where-  testEqualityFC _ Empty Empty = return Refl-  testEqualityFC test (PlusZero _ x1) (PlusZero _ y1) = do-    Refl <- testEqualityFC test x1 y1-    return Refl-  testEqualityFC test (PlusOne _ x1 x2) (PlusOne _ y1 y2) = do-    Refl <- testEqualityFC test x1 y1-    Refl <- testEqualityFC test x2 y2-    return Refl-  testEqualityFC _ _ _ = Nothing--instance OrdFC (BinomialTree h) where-  compareFC _ Empty Empty = EQF-  compareFC _ Empty _ = LTF-  compareFC _ _ Empty = GTF--  compareFC test (PlusZero _ x1) (PlusZero _ y1) =-    joinOrderingF (compareFC test x1 y1) $ EQF-  compareFC _ PlusZero{} _ = LTF-  compareFC _ _ PlusZero{} = GTF--  compareFC test (PlusOne _ x1 x2) (PlusOne _ y1 y2) =-    joinOrderingF (compareFC test x1 y1) $-    joinOrderingF (compareFC test x2 y2) $-    EQF--instance HashableF f => HashableF (BinomialTree h f) where-  hashWithSaltF s t =-    case t of-      Empty -> s-      PlusZero _ x   -> s `hashWithSaltF` x-      PlusOne  _ x y -> s `hashWithSaltF` x `hashWithSaltF` y---- | Map over a binary tree.-fmap_bin :: (forall tp . f tp -> g tp)-         -> BinomialTree h f c-         -> BinomialTree h g c-fmap_bin _ Empty = Empty-fmap_bin f (PlusOne s t x) = PlusOne s (fmap_bin f t) (fmap_bal f x)-fmap_bin f (PlusZero s t)  = PlusZero s (fmap_bin f t)-{-# INLINABLE fmap_bin #-}--traverse_bin :: Applicative m-             => (forall tp . f tp -> m (g tp))-             -> BinomialTree h f c-             -> m (BinomialTree h g c)-traverse_bin _ Empty = pure Empty-traverse_bin f (PlusOne s t x) = PlusOne s  <$> traverse_bin f t <*> traverse_bal f x-traverse_bin f (PlusZero s t)  = PlusZero s <$> traverse_bin f t-{-# INLINABLE traverse_bin #-}--unsafe_bin_generate :: forall h f ctx t-                     . Int -- ^ Size of tree to generate-                    -> Int -- ^ Height of each element.-                    -> (forall x . Index ctx x -> f x)-                    -> BinomialTree h f t-unsafe_bin_generate sz h f-  | sz == 0 = unsafeCoerce Empty-  | sz `testBit` 0 =-    let s = sz `shiftR` 1-        t = unsafe_bin_generate s (h+1) f-        o = s * 2^(h+1)-        u = assert (o == t_cnt_size t) $ unsafe_bal_generate h o f-     in unsafeCoerce (PlusOne s t u)-  | otherwise =-    let s = sz `shiftR` 1-        t = unsafe_bin_generate (sz `shiftR` 1) (h+1) f-        r :: BinomialTree h f t-        r = PlusZero s t-    in r--unsafe_bin_generateM :: forall m h f ctx t-                      . Applicative m-                     => Int -- ^ Size of tree to generate-                     -> Int -- ^ Height of each element.-                     -> (forall x . Index ctx x -> m (f x))-                     -> m (BinomialTree h f t)-unsafe_bin_generateM sz h f-  | sz == 0 = pure (unsafeCoerce Empty)-  | sz `testBit` 0 =-    let s = sz `shiftR` 1-        t = unsafe_bin_generateM s (h+1) f-        -- Next offset-        o = s * 2^(h+1)-        u = unsafe_bal_generateM h o f-        r = unsafeCoerce (PlusOne s) <$> t <*> u-     in r-  | otherwise =-    let s = sz `shiftR` 1-        t = unsafe_bin_generateM s (h+1) f-        r :: m (BinomialTree h f t)-        r = PlusZero s <$> t-     in r----------------------------------------------------------------------------- Dropping--data DropResult f (ctx :: Ctx k) where-  DropEmpty :: DropResult f EmptyCtx-  DropExt   :: BinomialTree 'Zero f x-            -> f y-            -> DropResult f (x ::> y)---- | 'bal_drop x y' returns the tree formed 'append x (init y)'-bal_drop :: forall h f x y-          . BinomialTree h f x-            -- ^ Bina-         -> BalancedTree h f y-         -> DropResult f (x <+> y)-bal_drop t (BalLeaf e) = DropExt t e-bal_drop t (BalPair x y) =-  unsafeCoerce (bal_drop (PlusOne (tsize t) (unsafeCoerce t) x) y)--bin_drop :: forall h f ctx-          . BinomialTree h f ctx-         -> DropResult f ctx-bin_drop Empty = DropEmpty-bin_drop (PlusZero _ u) = bin_drop u-bin_drop (PlusOne s t u) =-  let m = case t of-            Empty -> Empty-            _ -> PlusZero s t-   in bal_drop m u----------------------------------------------------------------------------- Indexing---- | Lookup value in tree.-unsafe_bin_index :: BinomialTree h f a -- ^ Tree to lookup in.-                 -> Int-                 -> Int -- ^ Size of tree-                 -> f u-unsafe_bin_index _ _ i-  | seq i False = error "bad unsafe_bin_index"-unsafe_bin_index Empty _ _ = error "unsafe_bin_index reached end of list"-unsafe_bin_index (PlusOne sz t u) j i-  | sz == j `shiftR` (1+i) = unsafe_bal_index u j i-  | otherwise = unsafe_bin_index t j $! (1+i)-unsafe_bin_index (PlusZero sz t) j i-  | sz == j `shiftR` (1+i) = error "unsafe_bin_index stopped at PlusZero"-  | otherwise = unsafe_bin_index t j $! (1+i)---- | Lookup value in tree.-unsafe_bin_adjust :: forall m h f x y a b-                   . Functor m-                  => (f x -> m (f y))-                  -> BinomialTree h f a -- ^ Tree to lookup in.-                  -> Int-                  -> Int -- ^ Size of tree-                  -> m (BinomialTree h f b)-unsafe_bin_adjust _ Empty _ _ = error "unsafe_bin_adjust reached end of list"-unsafe_bin_adjust f (PlusOne sz t u) j i-  | sz == j `shiftR` (1+i) =-    unsafeCoerce . PlusOne sz t        <$> (unsafe_bal_adjust f u j i)-  | otherwise =-    unsafeCoerce . flip (PlusOne sz) u <$> (unsafe_bin_adjust f t j (i+1))-unsafe_bin_adjust f (PlusZero sz t) j i-  | sz == j `shiftR` (1+i) = error "unsafe_bin_adjust stopped at PlusZero"-  | otherwise = PlusZero sz <$> (unsafe_bin_adjust f t j (i+1))---{-# SPECIALIZE unsafe_bin_adjust-     :: (f x -> Identity (f y))-     -> BinomialTree h f a-     -> Int-     -> Int-     -> Identity (BinomialTree h f b)-  #-}--tree_zipWithM :: Applicative m-             => (forall x . f x -> g x -> m (h x))-             -> BinomialTree u f a-             -> BinomialTree u g a-             -> m (BinomialTree u h a)-tree_zipWithM _ Empty Empty = pure Empty-tree_zipWithM f (PlusOne s x1 x2) (PlusOne _ y1 y2) =-  PlusOne s <$> tree_zipWithM f x1 (unsafeCoerce y1)-            <*> bal_zipWithM  f x2 (unsafeCoerce y2)-tree_zipWithM f (PlusZero s x1) (PlusZero _ y1) =-  PlusZero s <$> tree_zipWithM f x1 y1-tree_zipWithM _ _ _ = error "ilegal args to tree_zipWithM"-{-# INLINABLE tree_zipWithM #-}----------------------------------------------------------------------------- Assignment---- | An assignment is a sequence that maps each index with type 'tp' to--- a value of type 'f tp'.------ This assignment implementation uses a binomial tree implementation--- that offers lookups and updates in time and space logarithmic with--- respect to the number of elements in the context.-newtype Assignment (f :: k -> Type) (ctx :: Ctx k)-      = Assignment (BinomialTree 'Zero f ctx)--type role Assignment nominal nominal--instance NFData (Assignment f ctx) where-  rnf a = seq a ()---- | Return number of elements in assignment.-size :: Assignment f ctx -> Size ctx-size (Assignment t) = Size (tsize t)---- | @replicate n@ make a context with different copies of the same--- polymorphic value.-replicate :: Size ctx -> (forall tp . f tp) -> Assignment f ctx-replicate n c = generate n (\_ -> c)---- | Generate an assignment-generate :: Size ctx-         -> (forall tp . Index ctx tp -> f tp)-         -> Assignment f ctx-generate n f  = Assignment r-  where r = unsafe_bin_generate (sizeInt n) 0 f-{-# NOINLINE generate #-}---- | Generate an assignment-generateM :: Applicative m-          => Size ctx-          -> (forall tp . Index ctx tp -> m (f tp))-          -> m (Assignment f ctx)-generateM n f = Assignment <$> unsafe_bin_generateM (sizeInt n) 0 f-{-# NOINLINE generateM #-}---- | Return empty assignment-empty :: Assignment f EmptyCtx-empty = Assignment Empty--extend :: Assignment f ctx -> f x -> Assignment f (ctx ::> x)-extend (Assignment x) y = Assignment $ append x (BalLeaf y)---- | Unexported index that returns an arbitrary type of expression.-unsafeIndex :: proxy u -> Int -> Assignment f ctx -> f u-unsafeIndex _ idx (Assignment t) = seq t $ unsafe_bin_index t idx 0---- | Return value of assignment.-(!) :: Assignment f ctx -> Index ctx tp -> f tp-a ! Index i = assert (0 <= i && i < sizeInt (size a)) $-              unsafeIndex Proxy i a---- | Return value of assignment, where the index is into an---   initial sequence of the assignment.-(!^) :: KnownDiff l r => Assignment f r -> Index l tp -> f tp-a !^ i = a ! extendIndex i--instance TestEqualityFC Assignment where-   testEqualityFC test (Assignment x) (Assignment y) = do-     Refl <- testEqualityFC test x y-     return Refl--instance TestEquality f => TestEquality (Assignment f) where-  testEquality = testEqualityFC testEquality--instance TestEquality f => Eq (Assignment f ctx) where-  x == y = isJust (testEquality x y)--instance OrdFC Assignment where-  compareFC test (Assignment x) (Assignment y) =-     joinOrderingF (compareFC test x y) $ EQF--instance OrdF f => OrdF (Assignment f) where-  compareF = compareFC compareF--instance OrdF f => Ord (Assignment f ctx) where-  compare x y = toOrdering (compareF x y)--instance HashableF (Index ctx) where-  hashWithSaltF s i = hashWithSalt s (indexVal i)--instance Hashable (Index ctx tp) where-  hashWithSalt = hashWithSaltF--instance HashableF f => Hashable (Assignment f ctx) where-  hashWithSalt s (Assignment a) = hashWithSaltF s a--instance HashableF f => HashableF (Assignment f) where-  hashWithSaltF = hashWithSalt--instance ShowF f => Show (Assignment f ctx) where-  show a = "[" Prelude.++ intercalate ", " (toListFC showF a) Prelude.++ "]"--instance ShowF f => ShowF (Assignment f)--{-# DEPRECATED adjust "Replace 'adjust f i asgn' with 'Lens.over (ixF i) f asgn' instead." #-}-adjust :: (f tp -> f tp) -> Index ctx tp -> Assignment f ctx -> Assignment f ctx-adjust f idx asgn = runIdentity (adjustM (Identity . f) idx asgn)--{-# DEPRECATED update "Replace 'update idx val asgn' with 'Lens.set (ixF idx) val asgn' instead." #-}-update :: Index ctx tp -> f tp -> Assignment f ctx -> Assignment f ctx-update i v a = adjust (\_ -> v) i a---- | Modify the value of an assignment at a particular index.-adjustM :: Functor m => (f tp -> m (f tp)) -> Index ctx tp -> Assignment f ctx -> m (Assignment f ctx)-adjustM f (Index i) (Assignment a) = Assignment <$> (unsafe_bin_adjust f a i 0)-{-# SPECIALIZE adjustM :: (f tp -> Identity (f tp)) -> Index ctx tp -> Assignment f ctx -> Identity (Assignment f ctx) #-}--type instance IndexF       (Assignment f ctx) = Index ctx-type instance IxValueF     (Assignment f ctx) = f--instance forall (f :: k -> Type) ctx. IxedF' k (Assignment (f :: k -> Type) ctx) where-  ixF' :: Index ctx x -> Lens.Lens' (Assignment f ctx) (f x)-  ixF' idx f = adjustM f idx--instance forall (f :: k -> Type) ctx. IxedF k (Assignment f ctx) where-  ixF = ixF'---- This is an unsafe version of update that changes the type of the expression.-unsafeUpdate :: Int -> Assignment f ctx -> f u -> Assignment f ctx'-unsafeUpdate i (Assignment a) e = Assignment (runIdentity (unsafe_bin_adjust (\_ -> Identity e) a i 0))---- | View an assignment as either empty or an assignment with one appended.-data AssignView f ctx where-  AssignEmpty :: AssignView f EmptyCtx-  AssignExtend :: Assignment f ctx-               -> f tp-               -> AssignView f (ctx::>tp)---- | View an assignment as either empty or an assignment with one appended.-viewAssign :: forall f ctx . Assignment f ctx -> AssignView f ctx-viewAssign (Assignment x) =-  case bin_drop x of-    DropEmpty -> AssignEmpty-    DropExt t v -> AssignExtend (Assignment t) v--zipWith :: (forall x . f x -> g x -> h x)-        -> Assignment f a-        -> Assignment g a-        -> Assignment h a-zipWith f = \x y -> runIdentity $ zipWithM (\u v -> pure (f u v)) x y-{-# INLINE zipWith #-}--zipWithM :: Applicative m-         => (forall x . f x -> g x -> m (h x))-         -> Assignment f a-         -> Assignment g a-         -> m (Assignment h a)-zipWithM f (Assignment x) (Assignment y) = Assignment <$> tree_zipWithM f x y-{-# INLINABLE zipWithM #-}--instance FunctorFC Assignment where-  fmapFC = \f (Assignment x) -> Assignment (fmap_bin f x)-  {-# INLINE fmapFC #-}--instance FoldableFC Assignment where-  foldMapFC = foldMapFCDefault-  {-# INLINE foldMapFC #-}--instance TraversableFC Assignment where-  traverseFC = \f (Assignment x) -> Assignment <$> traverse_bin f x-  {-# INLINE traverseFC #-}--traverseWithIndex :: Applicative m-                  => (forall tp . Index ctx tp -> f tp -> m (g tp))-                  -> Assignment f ctx-                  -> m (Assignment g ctx)-traverseWithIndex f a = generateM (size a) $ \i -> f i (a ! i)----------------------------------------------------------------------------- Appending--appendBal :: Assignment f x -> BalancedTree h f y -> Assignment f (x <+> y)-appendBal x (BalLeaf a) = x `extend` a-appendBal x (BalPair y z) =-  case assoc x y z of-    Refl -> x `appendBal` y `appendBal` z--appendBin :: Assignment f x -> BinomialTree h f y -> Assignment f (x <+> y)-appendBin x Empty = x-appendBin x (PlusOne _ y z) =-  case assoc x y z of-    Refl -> x `appendBin` y `appendBal` z-appendBin x (PlusZero _ y) = x `appendBin` y--(<++>) :: Assignment f x -> Assignment f y -> Assignment f (x <+> y)-x <++> Assignment y = x `appendBin` y----------------------------------------------------------------------------- KnownRepr instances--instance (KnownRepr (Assignment f) ctx, KnownRepr f bt)-      => KnownRepr (Assignment f) (ctx ::> bt) where-  knownRepr = knownRepr `extend` knownRepr--instance KnownRepr (Assignment f) EmptyCtx where-  knownRepr = empty----------------------------------------------------------------------------- Lens combinators--unsafeLens :: Int -> Lens.Lens (Assignment f ctx) (Assignment f ctx') (f tp) (f u)-unsafeLens idx =-  Lens.lens (unsafeIndex Proxy idx) (unsafeUpdate idx)----------------------------------------------------------------------------- 1 field lens combinators--type Assignment1 f x1 = Assignment f ('EmptyCtx '::> x1)--instance Lens.Field1 (Assignment1 f t) (Assignment1 f u) (f t) (f u) where-  _1 = unsafeLens 0----------------------------------------------------------------------------- 2 field lens combinators--type Assignment2 f x1 x2-   = Assignment f ('EmptyCtx '::> x1 '::> x2)--instance Lens.Field1 (Assignment2 f t x2) (Assignment2 f u x2) (f t) (f u) where-  _1 = unsafeLens 0--instance Lens.Field2 (Assignment2 f x1 t) (Assignment2 f x1 u) (f t) (f u) where-  _2 = unsafeLens 1----------------------------------------------------------------------------- 3 field lens combinators--type Assignment3 f x1 x2 x3-   = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3)--instance Lens.Field1 (Assignment3 f t x2 x3)-                     (Assignment3 f u x2 x3)-                     (f t)-                     (f u) where-  _1 = unsafeLens 0---instance Lens.Field2 (Assignment3 f x1 t x3)-                     (Assignment3 f x1 u x3)-                     (f t)-                     (f u) where-  _2 = unsafeLens 1--instance Lens.Field3 (Assignment3 f x1 x2 t)-                     (Assignment3 f x1 x2 u)-                     (f t)-                     (f u) where-  _3 = unsafeLens 2----------------------------------------------------------------------------- 4 field lens combinators--type Assignment4 f x1 x2 x3 x4-   = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4)--instance Lens.Field1 (Assignment4 f t x2 x3 x4)-                     (Assignment4 f u x2 x3 x4)-                     (f t)-                     (f u) where-  _1 = unsafeLens 0---instance Lens.Field2 (Assignment4 f x1 t x3 x4)-                     (Assignment4 f x1 u x3 x4)-                     (f t)-                     (f u) where-  _2 = unsafeLens 1--instance Lens.Field3 (Assignment4 f x1 x2 t x4)-                     (Assignment4 f x1 x2 u x4)-                     (f t)-                     (f u) where-  _3 = unsafeLens 2--instance Lens.Field4 (Assignment4 f x1 x2 x3 t)-                     (Assignment4 f x1 x2 x3 u)-                     (f t)-                     (f u) where-  _4 = unsafeLens 3----------------------------------------------------------------------------- 5 field lens combinators--type Assignment5 f x1 x2 x3 x4 x5-   = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5)--instance Lens.Field1 (Assignment5 f t x2 x3 x4 x5)-                     (Assignment5 f u x2 x3 x4 x5)-                     (f t)-                     (f u) where-  _1 = unsafeLens 0--instance Lens.Field2 (Assignment5 f x1 t x3 x4 x5)-                     (Assignment5 f x1 u x3 x4 x5)-                     (f t)-                     (f u) where-  _2 = unsafeLens 1--instance Lens.Field3 (Assignment5 f x1 x2 t x4 x5)-                     (Assignment5 f x1 x2 u x4 x5)-                     (f t)-                     (f u) where-  _3 = unsafeLens 2--instance Lens.Field4 (Assignment5 f x1 x2 x3 t x5)-                     (Assignment5 f x1 x2 x3 u x5)-                     (f t)-                     (f u) where-  _4 = unsafeLens 3--instance Lens.Field5 (Assignment5 f x1 x2 x3 x4 t)-                     (Assignment5 f x1 x2 x3 x4 u)-                     (f t)-                     (f u) where-  _5 = unsafeLens 4----------------------------------------------------------------------------- 6 field lens combinators--type Assignment6 f x1 x2 x3 x4 x5 x6-   = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6)--instance Lens.Field1 (Assignment6 f t x2 x3 x4 x5 x6)-                     (Assignment6 f u x2 x3 x4 x5 x6)-                     (f t)-                     (f u) where-  _1 = unsafeLens 0---instance Lens.Field2 (Assignment6 f x1 t x3 x4 x5 x6)-                     (Assignment6 f x1 u x3 x4 x5 x6)-                     (f t)-                     (f u) where-  _2 = unsafeLens 1--instance Lens.Field3 (Assignment6 f x1 x2 t x4 x5 x6)-                     (Assignment6 f x1 x2 u x4 x5 x6)-                     (f t)-                     (f u) where-  _3 = unsafeLens 2--instance Lens.Field4 (Assignment6 f x1 x2 x3 t x5 x6)-                     (Assignment6 f x1 x2 x3 u x5 x6)-                     (f t)-                     (f u) where-  _4 = unsafeLens 3--instance Lens.Field5 (Assignment6 f x1 x2 x3 x4 t x6)-                     (Assignment6 f x1 x2 x3 x4 u x6)-                     (f t)-                     (f u) where-  _5 = unsafeLens 4--instance Lens.Field6 (Assignment6 f x1 x2 x3 x4 x5 t)-                     (Assignment6 f x1 x2 x3 x4 x5 u)-                     (f t)-                     (f u) where-  _6 = unsafeLens 5----------------------------------------------------------------------------- 7 field lens combinators--type Assignment7 f x1 x2 x3 x4 x5 x6 x7-   = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6 '::> x7)--instance Lens.Field1 (Assignment7 f t x2 x3 x4 x5 x6 x7)-                     (Assignment7 f u x2 x3 x4 x5 x6 x7)-                     (f t)-                     (f u) where-  _1 = unsafeLens 0---instance Lens.Field2 (Assignment7 f x1 t x3 x4 x5 x6 x7)-                     (Assignment7 f x1 u x3 x4 x5 x6 x7)-                     (f t)-                     (f u) where-  _2 = unsafeLens 1--instance Lens.Field3 (Assignment7 f x1 x2 t x4 x5 x6 x7)-                     (Assignment7 f x1 x2 u x4 x5 x6 x7)-                     (f t)-                     (f u) where-  _3 = unsafeLens 2--instance Lens.Field4 (Assignment7 f x1 x2 x3 t x5 x6 x7)-                     (Assignment7 f x1 x2 x3 u x5 x6 x7)-                     (f t)-                     (f u) where-  _4 = unsafeLens 3--instance Lens.Field5 (Assignment7 f x1 x2 x3 x4 t x6 x7)-                     (Assignment7 f x1 x2 x3 x4 u x6 x7)-                     (f t)-                     (f u) where-  _5 = unsafeLens 4--instance Lens.Field6 (Assignment7 f x1 x2 x3 x4 x5 t x7)-                     (Assignment7 f x1 x2 x3 x4 x5 u x7)-                     (f t)-                     (f u) where-  _6 = unsafeLens 5--instance Lens.Field7 (Assignment7 f x1 x2 x3 x4 x5 x6 t)-                     (Assignment7 f x1 x2 x3 x4 x5 x6 u)-                     (f t)-                     (f u) where-  _7 = unsafeLens 6----------------------------------------------------------------------------- 8 field lens combinators--type Assignment8 f x1 x2 x3 x4 x5 x6 x7 x8-   = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6 '::> x7 '::> x8)--instance Lens.Field1 (Assignment8 f t x2 x3 x4 x5 x6 x7 x8)-                     (Assignment8 f u x2 x3 x4 x5 x6 x7 x8)-                     (f t)-                     (f u) where-  _1 = unsafeLens 0---instance Lens.Field2 (Assignment8 f x1 t x3 x4 x5 x6 x7 x8)-                     (Assignment8 f x1 u x3 x4 x5 x6 x7 x8)-                     (f t)-                     (f u) where-  _2 = unsafeLens 1--instance Lens.Field3 (Assignment8 f x1 x2 t x4 x5 x6 x7 x8)-                     (Assignment8 f x1 x2 u x4 x5 x6 x7 x8)-                     (f t)-                     (f u) where-  _3 = unsafeLens 2--instance Lens.Field4 (Assignment8 f x1 x2 x3 t x5 x6 x7 x8)-                     (Assignment8 f x1 x2 x3 u x5 x6 x7 x8)-                     (f t)-                     (f u) where-  _4 = unsafeLens 3--instance Lens.Field5 (Assignment8 f x1 x2 x3 x4 t x6 x7 x8)-                     (Assignment8 f x1 x2 x3 x4 u x6 x7 x8)-                     (f t)-                     (f u) where-  _5 = unsafeLens 4--instance Lens.Field6 (Assignment8 f x1 x2 x3 x4 x5 t x7 x8)-                     (Assignment8 f x1 x2 x3 x4 x5 u x7 x8)-                     (f t)-                     (f u) where-  _6 = unsafeLens 5--instance Lens.Field7 (Assignment8 f x1 x2 x3 x4 x5 x6 t x8)-                     (Assignment8 f x1 x2 x3 x4 x5 x6 u x8)-                     (f t)-                     (f u) where-  _7 = unsafeLens 6--instance Lens.Field8 (Assignment8 f x1 x2 x3 x4 x5 x6 x7 t)-                     (Assignment8 f x1 x2 x3 x4 x5 x6 x7 u)-                     (f t)-                     (f u) where-  _8 = unsafeLens 7----------------------------------------------------------------------------- 9 field lens combinators--type Assignment9 f x1 x2 x3 x4 x5 x6 x7 x8 x9-   = Assignment f ('EmptyCtx '::> x1 '::> x2 '::> x3 '::> x4 '::> x5 '::> x6 '::> x7 '::> x8 '::> x9)---instance Lens.Field1 (Assignment9 f t x2 x3 x4 x5 x6 x7 x8 x9)-                     (Assignment9 f u x2 x3 x4 x5 x6 x7 x8 x9)-                     (f t)-                     (f u) where-  _1 = unsafeLens 0--instance Lens.Field2 (Assignment9 f x1 t x3 x4 x5 x6 x7 x8 x9)-                     (Assignment9 f x1 u x3 x4 x5 x6 x7 x8 x9)-                     (f t)-                     (f u) where-  _2 = unsafeLens 1--instance Lens.Field3 (Assignment9 f x1 x2 t x4 x5 x6 x7 x8 x9)-                     (Assignment9 f x1 x2 u x4 x5 x6 x7 x8 x9)-                     (f t)-                     (f u) where-  _3 = unsafeLens 2--instance Lens.Field4 (Assignment9 f x1 x2 x3 t x5 x6 x7 x8 x9)-                     (Assignment9 f x1 x2 x3 u x5 x6 x7 x8 x9)-                     (f t)-                     (f u) where-  _4 = unsafeLens 3--instance Lens.Field5 (Assignment9 f x1 x2 x3 x4 t x6 x7 x8 x9)-                     (Assignment9 f x1 x2 x3 x4 u x6 x7 x8 x9)-                     (f t)-                     (f u) where-  _5 = unsafeLens 4--instance Lens.Field6 (Assignment9 f x1 x2 x3 x4 x5 t x7 x8 x9)-                     (Assignment9 f x1 x2 x3 x4 x5 u x7 x8 x9)-                     (f t)-                     (f u) where-  _6 = unsafeLens 5--instance Lens.Field7 (Assignment9 f x1 x2 x3 x4 x5 x6 t x8 x9)-                     (Assignment9 f x1 x2 x3 x4 x5 x6 u x8 x9)-                     (f t)-                     (f u) where-  _7 = unsafeLens 6--instance Lens.Field8 (Assignment9 f x1 x2 x3 x4 x5 x6 x7 t x9)-                     (Assignment9 f x1 x2 x3 x4 x5 x6 x7 u x9)-                     (f t)-                     (f u) where-  _8 = unsafeLens 7--instance Lens.Field9 (Assignment9 f x1 x2 x3 x4 x5 x6 x7 x8 t)-                     (Assignment9 f x1 x2 x3 x4 x5 x6 x7 x8 u)-                     (f t)-                     (f u) where-  _9 = unsafeLens 8
− submodules/parameterized-utils/src/Data/Parameterized/Ctx.hs 
@@ -1,99 +0,0 @@-{-|-Description      : Type-level lists.-Copyright        : (c) Galois, Inc 2015-Maintainer       : Joe Hendrix <jhendrix@galois.com>--This module defines type-level lists used for representing the type of-variables in a context.--}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE Safe #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-module Data.Parameterized.Ctx-  ( type Ctx(..)-  , EmptyCtx-  , SingleCtx-  , (::>)-  , type (<+>)--    -- * Type context manipulation-  , CtxSize-  , CtxLookup-  , CtxUpdate-  , CtxLookupRight-  , CtxUpdateRight-  , CheckIx-  , ValidIx-  , FromLeft-  ) where--import Data.Kind (Constraint)-import GHC.TypeLits (Nat, type (+), type (-), type (<=?), TypeError, ErrorMessage(..))----------------------------------------------------------------------------- Ctx--type EmptyCtx = 'EmptyCtx-type (c :: Ctx k) ::> (a::k) = c '::> a--type SingleCtx x = EmptyCtx ::> x---- | Kind @'Ctx' k@ comprises lists of types of kind @k@.-data Ctx k-  = EmptyCtx-  | Ctx k ::> k---- | Append two type-level contexts.-type family (<+>) (x :: Ctx k) (y :: Ctx k) :: Ctx k where-  x <+> EmptyCtx = x-  x <+> (y ::> e) = (x <+> y) ::> e----- | This type family computes the number of elements in a 'Ctx'-type family CtxSize (a :: Ctx k) :: Nat where-  CtxSize 'EmptyCtx   = 0-  CtxSize (xs '::> x) = 1 + CtxSize xs---- | Helper type family used to generate descriptive error messages when--- an index is larger than the length of the 'Ctx' being indexed.-type family CheckIx (ctx :: Ctx k) (n :: Nat) (b :: Bool) :: Constraint where-  CheckIx ctx n 'True = ()-  CheckIx ctx n 'False = TypeError ('Text "Index "            ':<>: 'ShowType n-                              ':<>: 'Text " out of range in " ':<>: 'ShowType ctx)---- | A constraint that checks that the nat @n@ is a valid index into the---   context @ctx@, and raises a type error if not.-type ValidIx (n :: Nat) (ctx :: Ctx k)-  = CheckIx ctx n (n+1 <=? CtxSize ctx)---- | 'Ctx' is a snoc-list. In order to use the more intuitive left-to-right--- ordering of elements the desired index is subtracted from the total--- number of elements.-type FromLeft ctx n = CtxSize ctx - 1 - n---- | Lookup the value in a context by number, from the right-type family CtxLookupRight (n :: Nat) (ctx :: Ctx k) :: k where-  CtxLookupRight 0 (ctx '::> r) = r-  CtxLookupRight n (ctx '::> r) = CtxLookupRight (n-1) ctx---- | Update the value in a context by number, from the right.  If the index---   is out of range, the context is unchanged.-type family CtxUpdateRight (n :: Nat) (x::k) (ctx :: Ctx k) :: Ctx k where-  CtxUpdateRight n x 'EmptyCtx      = 'EmptyCtx-  CtxUpdateRight 0 x (ctx '::> old) = ctx '::> x-  CtxUpdateRight n x (ctx '::> y)   = CtxUpdateRight (n-1) x ctx '::> y---- | Lookup the value in a context by number, from the left.---   Produce a type error if the index is out of range.-type CtxLookup (n :: Nat) (ctx :: Ctx k)-  = CtxLookupRight (FromLeft ctx n) ctx---- | Update the value in a context by number, from the left.  If the index---   is out of range, the context is unchanged.-type CtxUpdate (n :: Nat) (x :: k) (ctx :: Ctx k)-  = CtxUpdateRight (FromLeft ctx n) x ctx
− submodules/parameterized-utils/src/Data/Parameterized/Ctx/Proofs.hs 
@@ -1,23 +0,0 @@-{-|-Copyright        : (c) Galois, Inc 2015-Maintainer       : Joe Hendrix <jhendrix@galois.com>--This reflects type level proofs involving contexts.--}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeOperators #-}-module Data.Parameterized.Ctx.Proofs-  ( leftId-  , assoc-  ) where--import Data.Type.Equality-import Unsafe.Coerce--import Data.Parameterized.Ctx--leftId :: p x -> (EmptyCtx <+> x) :~: x-leftId _ = unsafeCoerce Refl--assoc :: p x -> q y -> r z -> x <+> (y <+> z) :~: (x <+> y) <+> z-assoc _ _ _ = unsafeCoerce Refl
− submodules/parameterized-utils/src/Data/Parameterized/DecidableEq.hs 
@@ -1,37 +0,0 @@-{-|-Copyright        : (c) Galois, Inc 2014-2018-Maintainer       : Langston Barrett <langston@galois.com>--This defines a class @DecidableEq@, which represents decidable equality on a-type family.--This is different from GHC's @TestEquality@ in that it provides evidence-of non-equality. In fact, it is a superclass of @TestEquality@.--}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE Safe #-}-module Data.Parameterized.DecidableEq-  ( DecidableEq(..)-  ) where--import Data.Void (Void)-import Data.Type.Equality ((:~:))---- | Decidable equality.-class DecidableEq f where-  decEq :: f a -> f b -> Either (a :~: b) ((a :~: b) -> Void)---- TODO: instances for sums, products of types with decidable equality---- import Data.Type.Equality ((:~:), TestEquality(..))--- instance (DecidableEq f) => TestEquality f where---   testEquality a b =---     case decEq a b of---       Left  prf -> Just prf---       Right _   -> Nothing
− submodules/parameterized-utils/src/Data/Parameterized/HashTable.hs 
@@ -1,97 +0,0 @@---------------------------------------------------------------------------- |--- Module           : Data.Parameterized.HashTable--- Copyright        : (c) Galois, Inc 2014--- Maintainer       : Joe Hendrix <jhendrix@galois.com>------ This module provides a ST-based hashtable for parameterized keys and values.------ NOTE: This API makes use of unsafeCoerce to implement the parameterized--- hashtable abstraction.  This should be typesafe provided the--- 'TestEquality' instance on the key type is implemented soundly.--------------------------------------------------------------------------{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE Trustworthy #-}-module Data.Parameterized.HashTable-  ( HashTable-  , new-  , newSized-  , clone-  , lookup-  , insert-  , member-  , delete-  , clear-  , Data.Parameterized.Classes.HashableF(..)-  , Control.Monad.ST.RealWorld-  ) where--import Control.Applicative-import Control.Monad.ST-import qualified Data.HashTable.ST.Cuckoo as H-import GHC.Exts (Any)-import Unsafe.Coerce--import Prelude hiding (lookup)--import Data.Parameterized.Classes-import Data.Parameterized.Some---- | A hash table mapping nonces to values.-newtype HashTable s (key :: k -> *) (val :: k -> *)-      = HashTable (H.HashTable s (Some key) Any)---- | Create a new empty table.-new :: ST s (HashTable s key val)-new = HashTable <$> H.new---- | Create a new empty table to hold 'n' elements.-newSized :: Int -> ST s (HashTable s k v)-newSized n = HashTable <$> H.newSized n---- | Create a hash table that is a copy of the current one.-clone :: (HashableF key, TestEquality key)-      => HashTable s key val-      -> ST s (HashTable s key val)-clone (HashTable tbl) = do-  -- Create a new table-  r <- H.new-  -- Insert existing elements in-  H.mapM_ (uncurry (H.insert r)) tbl-  -- Return table-  return $! HashTable r---- | Lookup value of key in table.-lookup :: (HashableF key, TestEquality key)-       => HashTable s key val-       -> key tp-       -> ST s (Maybe (val tp))-lookup (HashTable h) k = fmap unsafeCoerce <$> H.lookup h (Some k)-{-# INLINE lookup #-}---- | Insert new key and value mapping into table.-insert :: (HashableF key, TestEquality key)-       => HashTable s (key :: k -> *) (val :: k -> *)-       -> key tp-       -> val tp-       -> ST s ()-insert (HashTable h) k v = H.insert h (Some k) (unsafeCoerce v)---- | Return true if the key is in the hash table.-member :: (HashableF key, TestEquality key)-       => HashTable s (key :: k -> *) (val :: k -> *)-       -> key (tp :: k)-       -> ST s Bool-member (HashTable h) k = isJust <$> H.lookup h (Some k)---- | Delete an element from the hash table.-delete :: (HashableF key, TestEquality key)-       => HashTable s (key :: k -> *) (val :: k -> *)-       -> key (tp :: k)-       -> ST s ()-delete (HashTable h) k = H.delete h (Some k)--clear :: (HashableF key, TestEquality key)-      => HashTable s (key :: k -> *) (val :: k -> *) -> ST s ()-clear (HashTable h) = H.mapM_ (\(k,_) -> H.delete h k) h
− submodules/parameterized-utils/src/Data/Parameterized/List.hs 
@@ -1,244 +0,0 @@-{-|-Copyright        : (c) Galois, Inc 2017-Maintainer       : Joe Hendrix <jhendrix@galois.com>--This module defines a list over two parameters.  The first-is a fixed type-level function @k -> *@ for some kind @k@, and the-second is a list of types with kind k that provide the indices for-the values in the list.--This type is closely related to the @Context@ type in-@Data.Parameterized.Context@.--}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeOperators #-}-module Data.Parameterized.List-  ( List(..)-  , Index(..)-  , indexValue-  , (!!)-  , update-  , indexed-  , imap-  , ifoldr-  , izipWith-  , itraverse-    -- * Constants-  , index0-  , index1-  , index2-  , index3-  ) where--import qualified Control.Lens as Lens-import Prelude hiding ((!!))--import Data.Parameterized.Classes-import Data.Parameterized.TraversableFC---- | Parameterized list of elements.-data List :: (k -> *) -> [k] -> * where-  Nil  :: List f '[]-  (:<) :: f tp -> List f tps -> List f (tp : tps)--infixr 5 :<--instance ShowF f => Show (List f sh) where-  showsPrec _ Nil = showString "Nil"-  showsPrec p (elt :< rest) = showParen (p > precCons) $-    -- Unlike a derived 'Show' instance, we don't print parens implied-    -- by right associativity.-    showsPrecF (precCons+1) elt . showString " :< " . showsPrec 0 rest-    where-      precCons = 5--instance ShowF f => ShowF (List f)--instance FunctorFC List where-  fmapFC _ Nil = Nil-  fmapFC f (x :< xs) = f x :< fmapFC f xs--instance FoldableFC List where-  foldrFC _ z Nil = z-  foldrFC f z (x :< xs) = f x (foldrFC f z xs)--instance TraversableFC List where-  traverseFC _ Nil = pure Nil-  traverseFC f (h :< r) = (:<) <$> f h <*> traverseFC f r--instance TestEquality f => TestEquality (List f) where-  testEquality Nil Nil = Just Refl-  testEquality (xh :< xl) (yh :< yl) = do-    Refl <- testEquality xh yh-    Refl <- testEquality xl yl-    pure Refl-  testEquality _ _ = Nothing--instance OrdF f => OrdF (List f) where-  compareF Nil Nil = EQF-  compareF Nil _ = LTF-  compareF _ Nil = GTF-  compareF (xh :< xl) (yh :< yl) =-    lexCompareF xh yh $-    lexCompareF xl yl $-    EQF---instance KnownRepr (List f) '[] where-  knownRepr = Nil--instance (KnownRepr f s, KnownRepr (List f) sh) => KnownRepr (List f) (s ': sh) where-  knownRepr = knownRepr :< knownRepr------------------------------------------------------------------------------------- Indexed operations----- | Represents an index into a type-level list. Used in place of integers to---   1. ensure that the given index *does* exist in the list---   2. guarantee that it has the given kind-data Index :: [k] -> k -> *  where-  IndexHere :: Index (x:r) x-  IndexThere :: !(Index r y) -> Index (x:r) y--deriving instance Eq (Index l x)-deriving instance Show  (Index l x)--instance ShowF (Index l)--instance TestEquality (Index l) where-  testEquality IndexHere IndexHere = Just Refl-  testEquality (IndexThere x) (IndexThere y) = testEquality x y-  testEquality _ _ = Nothing--instance OrdF (Index l) where-  compareF IndexHere IndexHere = EQF-  compareF IndexHere IndexThere{} = LTF-  compareF IndexThere{} IndexHere = GTF-  compareF (IndexThere x) (IndexThere y) = compareF x y--instance Ord (Index sh x) where-  x `compare` y = toOrdering $ x `compareF` y---- | Return the index as an integer.-indexValue :: Index l tp -> Integer-indexValue = go 0-  where go :: Integer -> Index l tp -> Integer-        go i IndexHere = i-        go i (IndexThere x) = seq j $ go j x-          where j = i+1---- | Index 0-index0 :: Index (x:r) x-index0 = IndexHere---- | Index 1-index1 :: Index (x0:x1:r) x1-index1 = IndexThere index0---- | Index 2-index2 :: Index (x0:x1:x2:r) x2-index2 = IndexThere index1---- | Index 3-index3 :: Index (x0:x1:x2:x3:r) x3-index3 = IndexThere index2---- | Return the value in a list at a given index-(!!) :: List f l -> Index l x -> f x-l !! (IndexThere i) =-  case l of-    _ :< r -> r !! i-l !! IndexHere =-  case l of-    (h :< _) -> h---- | Update the 'List' at an index-update :: List f l -> Index l s -> (f s -> f s) -> List f l-update vals IndexHere upd =-  case vals of-    x :< rest -> upd x :< rest-update vals (IndexThere th) upd =-  case vals of-    x :< rest -> x :< update rest th upd---- | Provides a lens for manipulating the element at the given index.-indexed :: Index l x -> Lens.Simple Lens.Lens (List f l) (f x)-indexed IndexHere      f (x :< rest) = (:< rest) <$> f x-indexed (IndexThere i) f (x :< rest) = (x :<) <$> indexed i f rest------------------------------------------------------------------------------------- Indexed operations---- | Map over the elements in the list, and provide the index into--- each element along with the element itself.-imap :: forall f g l-     . (forall x . Index l x -> f x -> g x)-     -> List f l-     -> List g l-imap f = go id-  where-    go :: forall l'-        . (forall tp . Index l' tp -> Index l tp)-       -> List f l'-       -> List g l'-    go g l =-      case l of-        Nil -> Nil-        e :< rest -> f (g IndexHere) e :< go (g . IndexThere) rest---- | Right-fold with an additional index.-ifoldr :: forall sh a b . (forall tp . Index sh tp -> a tp -> b -> b) -> b -> List a sh -> b-ifoldr f seed0 l = go id l seed0-  where-    go :: forall tps-        . (forall tp . Index tps tp -> Index sh tp)-       -> List a tps-       -> b-       -> b-    go g ops b =-      case ops of-        Nil -> b-        a :< rest -> f (g IndexHere) a (go (\ix -> g (IndexThere ix)) rest b)---- | Zip up two lists with a zipper function, which can use the index.-izipWith :: forall a b c sh . (forall tp. Index sh tp -> a tp -> b tp -> c tp)-         -> List a sh-         -> List b sh-         -> List c sh-izipWith f = go id-  where-    go :: forall sh' .-          (forall tp . Index sh' tp -> Index sh tp)-       -> List a sh'-       -> List b sh'-       -> List c sh'-    go g as bs =-      case (as, bs) of-        (Nil, Nil) -> Nil-        (a :< as', b :< bs') ->-          f (g IndexHere) a b :< go (g . IndexThere) as' bs'---- | Traverse with an additional index.-itraverse :: forall a b sh t-          . Applicative t-          => (forall tp . Index sh tp -> a tp -> t (b tp))-          -> List a sh-          -> t (List b sh)-itraverse f = go id-  where-    go :: forall tps . (forall tp . Index tps tp -> Index sh tp)-       -> List a tps-       -> t (List b tps)-    go g l =-      case l of-        Nil -> pure Nil-        e :< rest -> (:<) <$> f (g IndexHere) e <*> go (\ix -> g (IndexThere ix)) rest
− submodules/parameterized-utils/src/Data/Parameterized/Map.hs 
@@ -1,609 +0,0 @@-{-|-Copyright        : (c) Galois, Inc 2014-2017--This module defines finite maps where the key and value types are-parameterized by an arbitrary kind.--Some code was adapted from containers.--}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeInType #-}-module Data.Parameterized.Map-  ( MapF-    -- * Construction-  , Data.Parameterized.Map.empty-  , singleton-  , insert-  , insertWith-  , delete-  , union-    -- * Query-  , null-  , lookup-  , member-  , notMember-  , size-    -- * Conversion-  , keys-  , elems-  , fromList-  , toList-  , fromKeys-  , fromKeysM-   -- * Filter-  , filter-  , filterWithKey-  , filterGt-  , filterLt-    -- * Folds-  , foldlWithKey-  , foldlWithKey'-  , foldrWithKey-  , foldrWithKey'-  , foldMapWithKey-    -- * Traversal-  , map-  , mapWithKey-  , mapMaybe-  , mapMaybeWithKey-  , traverseWithKey-  , traverseWithKey_-    -- * Complex interface.-  , UpdateRequest(..)-  , Updated(..)-  , updatedValue-  , updateAtKey-  , mergeWithKeyM-  , module Data.Parameterized.Classes-    -- * Pair-  , Pair(..)-  ) where--import           Control.Applicative hiding (empty)-import           Control.Lens (Traversal', Lens')-import           Control.Monad.Identity-import           Data.Kind (Type)-import           Data.List (intercalate, foldl')-import           Data.Monoid--import           Data.Parameterized.Classes-import           Data.Parameterized.Some-import           Data.Parameterized.Pair ( Pair(..) )-import           Data.Parameterized.TraversableF-import           Data.Parameterized.Utils.BinTree-  ( MaybeS(..)-  , fromMaybeS-  , Updated(..)-  , updatedValue-  , TreeApp(..)-  , bin-  , IsBinTree(..)-  , balanceL-  , balanceR-  , glue-  )-import qualified Data.Parameterized.Utils.BinTree as Bin--#if MIN_VERSION_base(4,8,0)-import           Prelude hiding (filter, lookup, map, traverse, null)-#else-import           Prelude hiding (filter, lookup, map, null)-#endif----------------------------------------------------------------------------- Pair--comparePairKeys :: OrdF k => Pair k a -> Pair k a -> Ordering-comparePairKeys (Pair x _) (Pair y _) = toOrdering (compareF x y)-{-# INLINABLE comparePairKeys #-}----------------------------------------------------------------------------- MapF---- | A map from parameterized keys to values with the same parameter type.-data MapF (k :: v -> Type) (a :: v -> Type) where-  Bin :: {-# UNPACK #-}-         !Size -- Number of elements in tree.-      -> !(k x)-      -> !(a x)-      -> !(MapF k a)-      -> !(MapF k a)-      -> MapF k a-  Tip :: MapF k a--type Size = Int---- | Return empty map-empty :: MapF k a-empty = Tip---- | Return true if map is empty-null :: MapF k a -> Bool-null Tip = True-null Bin{} = False---- | Return map containing a single element-singleton :: k tp -> a tp -> MapF k a-singleton k x = Bin 1 k x Tip Tip--instance Bin.IsBinTree (MapF k a) (Pair k a) where-  asBin (Bin _ k v l r) = BinTree (Pair k v) l r-  asBin Tip = TipTree--  tip = Tip-  bin (Pair k v) l r = Bin (size l + size r + 1) k v l r--  size Tip              = 0-  size (Bin sz _ _ _ _) = sz--instance (TestEquality k, EqF a) => Eq (MapF k a) where-  x == y = size x == size y && toList x == toList y----------------------------------------------------------------------------- Traversals--#ifdef __GLASGOW_HASKELL__-{-# NOINLINE [1] map #-}-{-# NOINLINE [1] traverse #-}-{-# RULES-"map/map" forall (f :: (forall tp . f tp -> g tp)) (g :: (forall tp . g tp -> h tp)) xs-               . map g (map f xs) = map (g . f) xs-"map/traverse" forall (f :: (forall tp . f tp -> m (g tp))) (g :: (forall tp . g tp -> h tp)) xs-               . fmap (map g) (traverse f xs) = traverse (\v -> g <$> f v) xs-"traverse/map"-  forall (f :: (forall tp . f tp -> g tp)) (g :: (forall tp . g tp -> m (h tp))) xs-       . traverse g (map f xs) = traverse (\v -> g (f v)) xs-"traverse/traverse"-  forall (f :: (forall tp . f tp -> m (g tp))) (g :: (forall tp . g tp -> m (h tp))) xs-       . traverse f xs >>= traverse g = traverse (\v -> f v >>= g) xs- #-}-#endif----- | Apply function to all elements in map.-mapWithKey-  :: (forall tp . ktp tp -> f tp -> g tp)-  -> MapF ktp f-  -> MapF ktp g-mapWithKey _ Tip = Tip-mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)---- | Modify elements in a map-map :: (forall tp . f tp -> g tp) -> MapF ktp f -> MapF ktp g-map f = mapWithKey (\_ x -> f x)---- | Map keys and elements and collect `Just` results.-mapMaybeWithKey :: (forall tp . k tp -> f tp -> Maybe (g tp)) -> MapF k f -> MapF k g-mapMaybeWithKey _ Tip = Tip-mapMaybeWithKey f (Bin _ k x l r) =-  case f k x of-    Just y -> Bin.link (Pair k y) (mapMaybeWithKey f l) (mapMaybeWithKey f r)-    Nothing -> Bin.merge (mapMaybeWithKey f l) (mapMaybeWithKey f r)---- | Map elements and collect `Just` results.-mapMaybe :: (forall tp . f tp -> Maybe (g tp)) -> MapF ktp f -> MapF ktp g-mapMaybe f = mapMaybeWithKey (\_ x -> f x)---- | Traverse elements in a map-traverse :: Applicative m => (forall tp . f tp -> m (g tp)) -> MapF ktp f -> m (MapF ktp g)-traverse _ Tip = pure Tip-traverse f (Bin sx kx x l r) = Bin sx kx <$> f x <*> traverse f l <*> traverse f r---- | Traverse elements in a map-traverseWithKey-  :: Applicative m-  => (forall tp . ktp tp -> f tp -> m (g tp))-  -> MapF ktp f-  -> m (MapF ktp g)-traverseWithKey _ Tip = pure Tip-traverseWithKey f (Bin sx kx x l r) =-   Bin sx kx <$> f kx x <*> traverseWithKey f l <*> traverseWithKey f r---- | Traverse elements in a map without returning result.-traverseWithKey_-  :: Applicative m-  => (forall tp . ktp tp -> f tp -> m ())-  -> MapF ktp f-  -> m ()-traverseWithKey_ _ Tip = pure ()-traverseWithKey_ f (Bin _ kx x l r) = f kx x *> traverseWithKey_ f l *> traverseWithKey_ f r---type instance IndexF   (MapF k v) = k-type instance IxValueF (MapF k v) = v---- | Turn a map key into a traversal that visits the indicated element in the map, if it exists.-instance forall (k:: a -> Type) v. OrdF k => IxedF a (MapF k v) where-  ixF :: k x -> Traversal' (MapF k v) (v x)-  ixF i f m = updatedValue <$> updateAtKey i (pure Nothing) (\x -> Set <$> f x) m---- | Turn a map key into a lens that points into the indicated position in the map.-instance forall (k:: a -> Type) v. OrdF k => AtF a (MapF k v) where-  atF :: k x -> Lens' (MapF k v) (Maybe (v x))-  atF i f m = updatedValue <$> updateAtKey i (f Nothing) (\x -> maybe Delete Set <$> f (Just x)) m----- | Lookup value in map.-lookup :: OrdF k => k tp -> MapF k a -> Maybe (a tp)-lookup k0 = seq k0 (go k0)-  where-    go :: OrdF k => k tp -> MapF k a -> Maybe (a tp)-    go _ Tip = Nothing-    go k (Bin _ kx x l r) =-      case compareF k kx of-        LTF -> go k l-        GTF -> go k r-        EQF -> Just x-{-# INLINABLE lookup #-}---- | Return true if key is bound in map.-member :: OrdF k => k tp -> MapF k a -> Bool-member k0 = seq k0 (go k0)-  where-    go :: OrdF k => k tp -> MapF k a -> Bool-    go _ Tip = False-    go k (Bin _ kx _ l r) =-      case compareF k kx of-        LTF -> go k l-        GTF -> go k r-        EQF -> True-{-# INLINABLE member #-}---- | Return true if key is not bound in map.-notMember :: OrdF k => k tp -> MapF k a -> Bool-notMember k m = not $ member k m-{-# INLINABLE notMember #-}--instance FunctorF (MapF ktp) where-  fmapF = map--instance FoldableF (MapF ktp) where-  foldrF f z = go z-    where go z' Tip             = z'-          go z' (Bin _ _ x l r) = go (f x (go z' r)) l--instance TraversableF (MapF ktp) where-  traverseF = traverse--instance (ShowF ktp, ShowF rtp) => Show (MapF ktp rtp) where-  show m = showMap showF showF m---- | Return all keys of the map in ascending order.-keys :: MapF k a -> [Some k]-keys = foldrWithKey (\k _ l -> Some k : l) []---- | Return all elements of the map in the ascending order of their keys.-elems :: MapF k a -> [Some a]-elems = foldrF (\e l -> Some e : l) []---- | Perform a left fold with the key also provided.-foldlWithKey :: (forall s . b -> k s -> a s -> b) -> b -> MapF k a -> b-foldlWithKey _ z Tip = z-foldlWithKey f z (Bin _ kx x l r) =-  let lz = foldlWithKey f z l-      kz = f lz kx x-   in foldlWithKey f kz r---- | Perform a strict left fold with the key also provided.-foldlWithKey' :: (forall s . b -> k s -> a s -> b) -> b -> MapF k a -> b-foldlWithKey' _ z Tip = z-foldlWithKey' f z (Bin _ kx x l r) =-  let lz = foldlWithKey f z l-      kz = seq lz $ f lz kx x-   in seq kz $ foldlWithKey f kz r---- | Perform a right fold with the key also provided.-foldrWithKey :: (forall s . k s -> a s -> b -> b) -> b -> MapF k a -> b-foldrWithKey _ z Tip = z-foldrWithKey f z (Bin _ kx x l r) =-  let rz = foldrWithKey f z r-      kz = f kx x rz-   in foldrWithKey f kz l---- | Perform a strict right fold with the key also provided.-foldrWithKey' :: (forall s . k s -> a s -> b -> b) -> b -> MapF k a -> b-foldrWithKey' _ z Tip = z-foldrWithKey' f z (Bin _ kx x l r) =-  let rz = foldrWithKey f z r-      kz = seq rz $ f kx x rz-   in seq kz $ foldrWithKey f kz l---- | Fold the keys and values using the given monoid.-foldMapWithKey :: Monoid m => (forall s . k s -> a s -> m) -> MapF k a -> m-foldMapWithKey _ Tip = mempty-foldMapWithKey f (Bin _ kx x l r) = foldMapWithKey f l <> f kx x <> foldMapWithKey f r--showMap :: (forall tp . ktp tp -> String)-        -> (forall tp . rtp tp -> String)-        -> MapF ktp rtp-        -> String-showMap ppk ppv m = "{ " ++ intercalate ", " l ++ " }"-  where l = foldrWithKey (\k a l0 -> (ppk k ++ " -> " ++ ppv a) : l0) [] m----------------------------------------------------------------------------- filter---- | Return entries with values that satisfy predicate.-filter :: (forall tp . f tp -> Bool) -> MapF k f -> MapF k f-filter f = filterWithKey (\_ v -> f v)---- | Return key-value pairs that satisfy predicate.-filterWithKey :: (forall tp . k tp -> f tp -> Bool) -> MapF k f -> MapF k f-filterWithKey _ Tip = Tip-filterWithKey f (Bin _ k x l r)-  | f k x     = Bin.link (Pair k x) (filterWithKey f l) (filterWithKey f r)-  | otherwise = Bin.merge (filterWithKey f l) (filterWithKey f r)--compareKeyPair :: OrdF k => k tp -> Pair k a -> Ordering-compareKeyPair k = \(Pair x _) -> toOrdering (compareF k x)---- | @filterGt k m@ returns submap of @m@ that only contains entries--- that are larger than @k@.-filterGt :: OrdF k => k tp -> MapF k v -> MapF k v-filterGt k m = fromMaybeS m (Bin.filterGt (compareKeyPair k) m)-{-# INLINABLE filterGt #-}---- | @filterLt k m@ returns submap of @m@ that only contains entries--- that are smaller than @k@.-filterLt :: OrdF k => k tp -> MapF k v -> MapF k v-filterLt k m = fromMaybeS m (Bin.filterLt (compareKeyPair k) m)-{-# INLINABLE filterLt #-}----------------------------------------------------------------------------- User operations---- | Insert a binding into the map, replacing the existing binding if needed.-insert :: OrdF k => k tp -> a tp -> MapF k a -> MapF k a-insert = \k v m -> seq k $ updatedValue (Bin.insert comparePairKeys (Pair k v) m)-{-# INLINABLE insert #-}--- {-# SPECIALIZE Bin.insert :: OrdF k => Pair k a -> MapF k a -> Updated (MapF k a) #-}---- | Insert a binding into the map, replacing the existing binding if needed.-insertWithImpl :: OrdF k => (a tp -> a tp -> a tp) -> k tp -> a tp -> MapF k a -> Updated (MapF k a)-insertWithImpl f k v t = seq k $-  case t of-    Tip -> Bin.Updated (Bin 1 k v Tip Tip)-    Bin sz yk yv l r ->-      case compareF k yk of-        LTF ->-          case insertWithImpl f k v l of-            Bin.Updated l'   -> Bin.Updated   (Bin.balanceL (Pair yk yv) l' r)-            Bin.Unchanged l' -> Bin.Unchanged (Bin sz yk yv l' r)-        GTF ->-          case insertWithImpl f k v r of-            Bin.Updated r'   -> Bin.Updated   (Bin.balanceR (Pair yk yv) l r')-            Bin.Unchanged r' -> Bin.Unchanged (Bin sz yk yv l r')-        EQF -> Bin.Unchanged (Bin sz yk (f v yv) l r)-{-# INLINABLE insertWithImpl #-}---- | @insertWith f new m@ inserts the binding into @m@.------ It inserts @f new old@ if @m@ already contains an equivaltn value--- @old@, and @new@ otherwise.  It returns an Unchanged value if the--- map stays the same size and an updated value if a new entry was--- inserted.-insertWith :: OrdF k => (a tp -> a tp -> a tp) -> k tp -> a tp -> MapF k a -> MapF k a-insertWith = \f k v t -> seq k $ updatedValue (insertWithImpl f k v t)-{-# INLINABLE insertWith #-}---- | Delete a value from the map if present.-delete :: OrdF k => k tp -> MapF k a -> MapF k a-delete = \k m -> seq k $ fromMaybeS m $ Bin.delete (p k) m-  where p :: OrdF k => k tp -> Pair k a -> Ordering-        p k (Pair kx _) = toOrdering (compareF k kx)-{-# INLINABLE delete #-}-{-# SPECIALIZE Bin.delete :: (Pair k a -> Ordering) -> MapF k a -> MaybeS (MapF k a) #-}---- | Union two sets-union :: OrdF k => MapF k a -> MapF k a -> MapF k a-union t1 t2 = Bin.union comparePairKeys t1 t2-{-# INLINABLE union #-}--- {-# SPECIALIZE Bin.union compare :: OrdF k => MapF k a -> MapF k a -> MapF k a #-}----------------------------------------------------------------------------- updateAtKey---- | Update request tells when to do with value-data UpdateRequest v-   = -- | Keep the current value.-     Keep-     -- | Set the value to a new value.-   | Set !v-     -- | Delete a value.-   | Delete--data AtKeyResult k a where-  AtKeyUnchanged :: AtKeyResult k a-  AtKeyInserted :: MapF k a -> AtKeyResult k a-  AtKeyModified :: MapF k a -> AtKeyResult k a-  AtKeyDeleted  :: MapF k a -> AtKeyResult k a--atKey' :: (OrdF k, Functor f)-       => k tp-       -> f (Maybe (a tp)) -- ^ Function to call if no element is found.-       -> (a tp -> f (UpdateRequest (a tp)))-       -> MapF k a-       -> f (AtKeyResult k a)-atKey' k onNotFound onFound t =-  case asBin t of-    TipTree -> ins <$> onNotFound-      where ins Nothing  = AtKeyUnchanged-            ins (Just v) = AtKeyInserted (singleton k v)-    BinTree yp@(Pair kx y) l r ->-      case compareF k kx of-        LTF -> ins <$> atKey' k onNotFound onFound l-          where ins AtKeyUnchanged = AtKeyUnchanged-                ins (AtKeyInserted l') = AtKeyInserted (balanceL yp l' r)-                ins (AtKeyModified l') = AtKeyModified (bin      yp l' r)-                ins (AtKeyDeleted  l') = AtKeyDeleted  (balanceR yp l' r)-        GTF -> ins <$> atKey' k onNotFound onFound r-          where ins AtKeyUnchanged = AtKeyUnchanged-                ins (AtKeyInserted r') = AtKeyInserted (balanceR yp l r')-                ins (AtKeyModified r') = AtKeyModified (bin      yp l r')-                ins (AtKeyDeleted  r') = AtKeyDeleted  (balanceL yp l r')-        EQF -> ins <$> onFound y-          where ins Keep    = AtKeyUnchanged-                ins (Set x) = AtKeyModified (bin (Pair kx x) l r)-                ins Delete  = AtKeyDeleted (glue l r)-{-# INLINABLE atKey' #-}---- | Log-time algorithm that allows a value at a specific key to be added, replaced,--- or deleted.-updateAtKey :: (OrdF k, Functor f)-            => k tp -- ^ Key to update-            -> f (Maybe (a tp))-               -- ^ Action to call if nothing is found-            -> (a tp -> f (UpdateRequest (a tp)))-               -- ^ Action to call if value is found.-            -> MapF k a-               -- ^ Map to update-            -> f (Updated (MapF k a))-updateAtKey k onNotFound onFound t = ins <$> atKey' k onNotFound onFound t-  where ins AtKeyUnchanged = Unchanged t-        ins (AtKeyInserted t') = Updated t'-        ins (AtKeyModified t') = Updated t'-        ins (AtKeyDeleted  t') = Updated t'-{-# INLINABLE updateAtKey #-}---- | Create a Map from a list of pairs.-fromList :: OrdF k => [Pair k a] -> MapF k a-fromList = foldl' (\m (Pair k a) -> insert k a m) Data.Parameterized.Map.empty--toList :: MapF k a -> [Pair k a]-toList = foldrWithKey (\k x m -> Pair k x : m) []---- | Generate a map from a foldable collection of keys and a--- function from keys to values.-fromKeys :: forall m (t :: Type -> Type) (a :: k -> Type) (v :: k -> Type)-          .  (Monad m, Foldable t, OrdF a)-            => (forall tp . a tp -> m (v tp))-            -- ^ Function for evaluating a register value.-            -> t (Some a)-               -- ^ Set of X86 registers-            -> m (MapF a v)-fromKeys f = foldM go empty-  where go :: MapF a v -> Some a -> m (MapF a v)-        go m (Some k) = (\v -> insert k v m) <$> f k---- | Generate a map from a foldable collection of keys and a monadic--- function from keys to values.-fromKeysM :: forall m (t :: Type -> Type) (a :: k -> Type) (v :: k -> Type)-          .  (Monad m, Foldable t, OrdF a)-           => (forall tp . a tp -> m (v tp))-           -- ^ Function for evaluating a register value.-           -> t (Some a)-           -- ^ Set of X86 registers-           -> m (MapF a v)-fromKeysM f = foldM go empty-  where go :: MapF a v -> Some a -> m (MapF a v)-        go m (Some k) = (\v -> insert k v m) <$> f k--filterGtMaybe :: OrdF k => MaybeS (k x) -> MapF k a -> MapF k a-filterGtMaybe NothingS m = m-filterGtMaybe (JustS k) m = filterGt k m--filterLtMaybe :: OrdF k => MaybeS (k x) -> MapF k a -> MapF k a-filterLtMaybe NothingS m = m-filterLtMaybe (JustS k) m = filterLt k m---- | Merge bindings in two maps to get a third.-mergeWithKeyM :: forall k a b c m-               . (Applicative m, OrdF k)-              => (forall tp . k tp -> a tp -> b tp -> m (Maybe (c tp)))-              -> (MapF k a -> m (MapF k c))-              -> (MapF k b -> m (MapF k c))-              -> MapF k a-              -> MapF k b-              -> m (MapF k c)-mergeWithKeyM f g1 g2 = go-  where-    go Tip t2 = g2 t2-    go t1 Tip = g1 t1-    go t1 t2 = hedgeMerge NothingS NothingS t1 t2--    hedgeMerge :: MaybeS (k x) -> MaybeS (k y) -> MapF k a -> MapF k b -> m (MapF k c)-    hedgeMerge _   _   t1  Tip = g1 t1-    hedgeMerge blo bhi Tip (Bin _ kx x l r) =-      g2 $ Bin.link (Pair kx x) (filterGtMaybe blo l) (filterLtMaybe bhi r)-    hedgeMerge blo bhi (Bin _ kx x l r) t2 =-        let Bin.PairS found trim_t2 = trimLookupLo kx bhi t2-            resolve_g1 :: MapF k c -> MapF k c -> MapF k c -> MapF k c-            resolve_g1 Tip = Bin.merge-            resolve_g1 (Bin _ k' x' Tip Tip) = Bin.link (Pair k' x')-            resolve_g1 _ = error "mergeWithKey: Bad function g1"-            resolve_f Nothing = Bin.merge-            resolve_f (Just x') = Bin.link (Pair kx x')-         in case found of-              Nothing ->-                resolve_g1 <$> g1 (singleton kx x)-                           <*> hedgeMerge blo bmi l (trim blo bmi t2)-                           <*> hedgeMerge bmi bhi r trim_t2-              Just x2 ->-                resolve_f <$> f kx x x2-                          <*> hedgeMerge blo bmi l (trim blo bmi t2)-                          <*> hedgeMerge bmi bhi r trim_t2-      where bmi = JustS kx-{-# INLINABLE mergeWithKeyM #-}--{---------------------------------------------------------------------  [trim blo bhi t] trims away all subtrees that surely contain no-  values between the range [blo] to [bhi]. The returned tree is either-  empty or the key of the root is between @blo@ and @bhi@.---------------------------------------------------------------------}-trim :: OrdF k => MaybeS (k x) -> MaybeS (k y) -> MapF k a -> MapF k a-trim NothingS   NothingS   t = t-trim (JustS lk) NothingS   t = filterGt lk t-trim NothingS   (JustS hk) t = filterLt hk t-trim (JustS lk) (JustS hk) t = filterMiddle lk hk t---- | Returns only entries that are strictly between the two keys.-filterMiddle :: OrdF k => k x -> k y -> MapF k a -> MapF k a-filterMiddle lo hi (Bin _ k _ _ r)-  | k `leqF` lo = filterMiddle lo hi r-filterMiddle lo hi (Bin _ k _ l _)-  | k `geqF` hi = filterMiddle lo hi l-filterMiddle _  _  t = t-{-# INLINABLE filterMiddle #-}------ Helper function for 'mergeWithKey'. The @'trimLookupLo' lk hk t@ performs both--- @'trim' (JustS lk) hk t@ and @'lookup' lk t@.---- See Note: Type of local 'go' function-trimLookupLo :: OrdF k => k tp -> MaybeS (k y) -> MapF k a -> Bin.PairS (Maybe (a tp)) (MapF k a)-trimLookupLo lk NothingS t = greater lk t-  where greater :: OrdF k => k tp -> MapF k a -> Bin.PairS (Maybe (a tp)) (MapF k a)-        greater lo t'@(Bin _ kx x l r) =-           case compareF lo kx of-             LTF -> Bin.PairS (lookup lo l) t'-             EQF -> Bin.PairS (Just x) r-             GTF -> greater lo r-        greater _ Tip = Bin.PairS Nothing Tip-trimLookupLo lk (JustS hk) t = middle lk hk t-  where middle :: OrdF k => k tp -> k y -> MapF k a -> Bin.PairS (Maybe (a tp)) (MapF k a)-        middle lo hi t'@(Bin _ kx x l r) =-          case compareF lo kx of-            LTF | kx `ltF` hi -> Bin.PairS (lookup lo l) t'-                | otherwise -> middle lo hi l-            EQF -> Bin.PairS (Just x) (lesser hi r)-            GTF -> middle lo hi r-        middle _ _ Tip = Bin.PairS Nothing Tip--        lesser :: OrdF k => k y -> MapF k a -> MapF k a-        lesser hi (Bin _ k _ l _) | k `geqF` hi = lesser hi l-        lesser _ t' = t'
− submodules/parameterized-utils/src/Data/Parameterized/NatRepr.hs 
@@ -1,690 +0,0 @@-{-|-Copyright        : (c) Galois, Inc 2014-2018-Maintainer       : Joe Hendrix <jhendrix@galois.com>--This defines a type 'NatRepr' for representing a type-level natural-at runtime.  This can be used to branch on a type-level value.  For-each @n@, @NatRepr n@ contains a single value containing the vlaue-@n@.  This can be used to help use type-level variables on code-with data dependendent types.--The @TestEquality@ and @DecidableEq@ instances for 'NatRepr'-are implemented using 'unsafeCoerce', as is the `isZeroNat` function. This-should be typesafe because we maintain the invariant that the integer value-contained in a NatRepr value matches its static type.--}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeApplications #-}-#if MIN_VERSION_base(4,9,0)-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}-#endif-#if __GLASGOW_HASKELL__ >= 805-{-# LANGUAGE NoStarIsType #-}-#endif-module Data.Parameterized.NatRepr-  ( NatRepr-  , natValue-  , intValue-  , knownNat-  , withKnownNat-  , IsZeroNat(..)-  , isZeroNat-  , isZeroOrGT1-  , NatComparison(..)-  , compareNat-  , decNat-  , predNat-  , incNat-  , addNat-  , subNat-  , divNat-  , halfNat-  , withDivModNat-  , natMultiply-  , someNat-  , mkNatRepr-  , maxNat-  , natRec-  , natRecStrong-  , natRecBounded-  , natForEach-  , natFromZero-  , NatCases(..)-  , testNatCases-    -- * Strict order-  , lessThanIrreflexive-  , lessThanAsymmetric-    -- * Bitvector utilities-  , widthVal-  , minUnsigned-  , maxUnsigned-  , minSigned-  , maxSigned-  , toUnsigned-  , toSigned-  , unsignedClamp-  , signedClamp-    -- * LeqProof-  , LeqProof(..)-  , decideLeq-  , testLeq-  , testStrictLeq-  , leqRefl-  , leqTrans-  , leqAdd2-  , leqSub2-  , leqMulCongr-    -- * LeqProof combinators-  , leqProof-  , withLeqProof-  , isPosNat-  , leqAdd-  , leqSub-  , leqMulPos-  , leqAddPos-  , addIsLeq-  , withAddLeq-  , addPrefixIsLeq-  , withAddPrefixLeq-  , addIsLeqLeft1-  , dblPosIsPos-  , leqMulMono-    -- * Arithmetic proof-  , plusComm-  , mulComm-  , plusMinusCancel-  , minusPlusCancel-  , addMulDistribRight-  , withAddMulDistribRight-  , withSubMulDistribRight-  , mulCancelR-  , mul2Plus-  , lemmaMul-    -- * Re-exports typelists basics---  , NatK-  , type (+)-  , type (-)-  , type (*)-  , type (<=)-  , Equality.TestEquality(..)-  , (Equality.:~:)(..)-  , Data.Parameterized.Some.Some-    -- * Backdoor, no touchy-  , activateNatReprCoercionBackdoor_IPromiseIKnowWhatIAmDoing-  ) where--import Data.Bits ((.&.), bit)-import Data.Hashable-import Data.Proxy as Proxy-import Data.Type.Equality as Equality-import Data.Void as Void-import Numeric.Natural-import GHC.TypeNats as TypeNats-import Unsafe.Coerce--import Data.Parameterized.Classes-import Data.Parameterized.DecidableEq-import Data.Parameterized.Some--maxInt :: Natural-maxInt = fromIntegral (maxBound :: Int)----------------------------------------------------------------------------- Nat---- | A runtime presentation of a type-level 'Nat'.------ This can be used for performing dynamic checks on a type-level natural--- numbers.-newtype NatRepr (n::Nat) = NatRepr { natValue :: Natural-                                     -- ^ The underlying natural value of the number.-                                   }-  deriving (Hashable)--type role NatRepr nominal--intValue :: NatRepr n -> Integer-intValue n = toInteger (natValue n)-{-# INLINE intValue #-}---- | If you are not 110% sure what the consequences of using this are and---   how to use it, don't.-activateNatReprCoercionBackdoor_IPromiseIKnowWhatIAmDoing :: ((Natural -> NatRepr n) -> a) -> a-activateNatReprCoercionBackdoor_IPromiseIKnowWhatIAmDoing k = k NatRepr-{-# INLINE activateNatReprCoercionBackdoor_IPromiseIKnowWhatIAmDoing #-}---- | Return the value of the nat representation.-widthVal :: NatRepr n -> Int-widthVal (NatRepr i) | i <= maxInt = fromIntegral i-                     | otherwise   = error ("Width is too large: " ++ show i)--instance Eq (NatRepr m) where-  _ == _ = True--instance TestEquality NatRepr where-  testEquality (NatRepr m) (NatRepr n)-    | m == n = Just (unsafeCoerce Refl)-    | otherwise = Nothing--instance DecidableEq NatRepr where-  decEq (NatRepr m) (NatRepr n)-    | m == n    = Left $ unsafeCoerce Refl-    | otherwise = Right $-        \x -> seq x $ error "Impossible [DecidableEq on NatRepr]"---- | Result of comparing two numbers.-data NatComparison m n where-  -- First number is less than second.-  NatLT :: x+1 <= x+(y+1) => !(NatRepr y) -> NatComparison x (x+(y+1))-  NatEQ :: NatComparison x x-  -- First number is greater than second.-  NatGT :: x+1 <= x+(y+1) => !(NatRepr y) -> NatComparison (x+(y+1)) x--compareNat :: NatRepr m -> NatRepr n -> NatComparison m n-compareNat m n =-  case compare (natValue m) (natValue n) of-    LT -> unsafeCoerce (NatLT @0 @0) (NatRepr (natValue n - natValue m - 1))-    EQ -> unsafeCoerce  NatEQ-    GT -> unsafeCoerce (NatGT @0 @0) (NatRepr (natValue m - natValue n - 1))--instance OrdF NatRepr where-  compareF x y =-    case compareNat x y of-      NatLT _ -> LTF-      NatEQ -> EQF-      NatGT _ -> GTF--instance PolyEq (NatRepr m) (NatRepr n) where-  polyEqF x y = fmap (\Refl -> Refl) $ testEquality x y--instance Show (NatRepr n) where-  show (NatRepr n) = show n--instance ShowF NatRepr--instance HashableF NatRepr where-  hashWithSaltF = hashWithSalt---- | This generates a NatRepr from a type-level context.-knownNat :: forall n . KnownNat n => NatRepr n-knownNat = NatRepr (natVal (Proxy :: Proxy n))--instance (KnownNat n) => KnownRepr NatRepr n where-  knownRepr = knownNat--withKnownNat :: forall n r. NatRepr n -> (KnownNat n => r) -> r-withKnownNat (NatRepr nVal) v =-  case someNatVal nVal of-    SomeNat (Proxy :: Proxy n') ->-      case unsafeCoerce (Refl :: n :~: n) :: n :~: n' of-        Refl -> v--data IsZeroNat n where-  ZeroNat    :: IsZeroNat 0-  NonZeroNat :: IsZeroNat (n+1)--isZeroNat :: NatRepr n -> IsZeroNat n-isZeroNat (NatRepr 0) = unsafeCoerce ZeroNat-isZeroNat (NatRepr _) = unsafeCoerce NonZeroNat---- | Every nat is either zero or >= 1.-isZeroOrGT1 :: NatRepr n -> Either (n :~: 0) (LeqProof 1 n)-isZeroOrGT1 n =-  case isZeroNat n of-    ZeroNat    -> Left Refl-    NonZeroNat -> Right $-      -- We have n = m + 1 for some m.-      let-        -- | x <= x + 1-        leqSucc:: forall x. LeqProof x (x+1)-        leqSucc = leqAdd2 (LeqProof :: LeqProof x x) (LeqProof :: LeqProof 0 1)-        leqPlus :: forall f x y. ((x + 1) ~ y) => f x ->  LeqProof 1 y-        leqPlus fx =-          case (plusComm fx (knownNat @1) :: x + 1 :~: 1 + x)    of { Refl ->-          case (plusMinusCancel (knownNat @1) fx :: 1+x-x :~: 1) of { Refl ->-          case (LeqProof :: LeqProof (x+1) y)                    of { LeqProof ->-          case (LeqProof :: LeqProof (1+x-x) (y-x))              of { LeqProof ->-            leqTrans (LeqProof :: LeqProof 1 (y-x))-                     (leqSub (LeqProof :: LeqProof y y)-                             (leqTrans (leqSucc :: LeqProof x (x+1))-                                       (LeqProof) :: LeqProof x y) :: LeqProof (y - x) y)-          }}}}-      in leqPlus (predNat n)---- | Decrement a @NatRepr@-decNat :: (1 <= n) => NatRepr n -> NatRepr (n-1)-decNat (NatRepr i) = NatRepr (i-1)---- | Get the predecessor of a nat-predNat :: NatRepr (n+1) -> NatRepr n-predNat (NatRepr i) = NatRepr (i-1)---- | Increment a @NatRepr@-incNat :: NatRepr n -> NatRepr (n+1)-incNat (NatRepr x) = NatRepr (x+1)--halfNat :: NatRepr (n+n) -> NatRepr n-halfNat (NatRepr x) = NatRepr (x `div` 2)--addNat :: NatRepr m -> NatRepr n -> NatRepr (m+n)-addNat (NatRepr m) (NatRepr n) = NatRepr (m+n)--subNat :: (n <= m) => NatRepr m -> NatRepr n -> NatRepr (m-n)-subNat (NatRepr m) (NatRepr n) = NatRepr (m-n)--divNat :: (1 <= n) => NatRepr (m * n) -> NatRepr n -> NatRepr m-divNat (NatRepr x) (NatRepr y) = NatRepr (div x y)--withDivModNat :: forall n m a.-                 NatRepr n-              -> NatRepr m-              -> (forall div mod. (n ~ ((div * m) + mod)) =>-                  NatRepr div -> NatRepr mod -> a)-              -> a-withDivModNat n m f =-  case ( Some (NatRepr divPart), Some (NatRepr modPart)) of-     ( Some (divn :: NatRepr div), Some (modn :: NatRepr mod) )-       -> case unsafeCoerce (Refl :: 0 :~: 0) of-            (Refl :: (n :~: ((div * m) + mod))) -> f divn modn-  where-    (divPart, modPart) = divMod (natValue n) (natValue m)--natMultiply :: NatRepr n -> NatRepr m -> NatRepr (n * m)-natMultiply (NatRepr n) (NatRepr m) = NatRepr (n * m)----------------------------------------------------------------------------- Operations for using NatRepr as a bitwidth.---- | Return minimum unsigned value for bitvector with given width (always 0).-minUnsigned :: NatRepr w -> Integer-minUnsigned _ = 0---- | Return maximum unsigned value for bitvector with given width.-maxUnsigned :: NatRepr w -> Integer-maxUnsigned w = bit (widthVal w) - 1---- | Return minimum value for bitvector in 2s complement with given width.-minSigned :: (1 <= w) => NatRepr w -> Integer-minSigned w = negate (bit (widthVal w - 1))---- | Return maximum value for bitvector in 2s complement with given width.-maxSigned :: (1 <= w) => NatRepr w -> Integer-maxSigned w = bit (widthVal w - 1) - 1---- | @toUnsigned w i@ maps @i@ to a @i `mod` 2^w@.-toUnsigned :: NatRepr w -> Integer -> Integer-toUnsigned w i = maxUnsigned w .&. i---- | @toSigned w i@ interprets the least-significant @w@ bits in @i@ as a--- signed number in two's complement notation and returns that value.-toSigned :: (1 <= w) => NatRepr w -> Integer -> Integer-toSigned w i0-    | i > maxSigned w = i - bit (widthVal w)-    | otherwise       = i-  where i = i0 .&. maxUnsigned w---- | @unsignedClamp w i@ rounds @i@ to the nearest value between--- @0@ and @2^w-1@ (inclusive).-unsignedClamp :: NatRepr w -> Integer -> Integer-unsignedClamp w i-  | i < minUnsigned w = minUnsigned w-  | i > maxUnsigned w = maxUnsigned w-  | otherwise         = i---- | @signedClamp w i@ rounds @i@ to the nearest value between--- @-2^(w-1)@ and @2^(w-1)-1@ (inclusive).-signedClamp :: (1 <= w) => NatRepr w -> Integer -> Integer-signedClamp w i-  | i < minSigned w = minSigned w-  | i > maxSigned w = maxSigned w-  | otherwise       = i----------------------------------------------------------------------------- Some NatRepr---- | Turn an @Integral@ value into a @NatRepr@.  Returns @Nothing@---   if the given value is negative.-someNat :: Integral a => a -> Maybe (Some NatRepr)-someNat x | x >= 0 = Just . Some . NatRepr $! fromIntegral x-someNat _ = Nothing---- | Turn a @Natural@ into the corresponding @NatRepr@-mkNatRepr :: Natural -> Some NatRepr-mkNatRepr n = Some (NatRepr n)---- | Return the maximum of two nat representations.-maxNat :: NatRepr m -> NatRepr n -> Some NatRepr-maxNat x y-  | natValue x >= natValue y = Some x-  | otherwise = Some y----------------------------------------------------------------------------- Arithmetic---- | Produce evidence that + is commutative.-plusComm :: forall f m g n . f m -> g n -> m+n :~: n+m-plusComm _ _ = unsafeCoerce (Refl :: m+n :~: m+n)---- | Produce evidence that * is commutative.-mulComm :: forall f m g n. f m -> g n -> (m * n) :~: (n * m)-mulComm _ _ = unsafeCoerce Refl--mul2Plus :: forall f n. f n -> (n + n) :~: (2 * n)-mul2Plus n = case addMulDistribRight (Proxy @1) (Proxy @1) n of-               Refl -> Refl---- | Cancel an add followed b a subtract-plusMinusCancel :: forall f m g n . f m -> g n -> (m + n) - n :~: m-plusMinusCancel _ _ = unsafeCoerce (Refl :: m :~: m)--minusPlusCancel :: forall f m g n . (n <= m) => f m -> g n -> (m - n) + n :~: m-minusPlusCancel _ _ = unsafeCoerce (Refl :: m :~: m)--addMulDistribRight :: forall n m p f g h. f n -> g m -> h p-                    -> ((n * p) + (m * p)) :~: ((n + m) * p)-addMulDistribRight _n _m _p = unsafeCoerce Refl----withAddMulDistribRight :: forall n m p f g h a. f n -> g m -> h p-                    -> ( (((n * p) + (m * p)) ~ ((n + m) * p)) => a) -> a-withAddMulDistribRight n m p f =-  case addMulDistribRight n m p of-    Refl -> f--withSubMulDistribRight :: forall n m p f g h a. (m <= n) => f n -> g m -> h p-                    -> ( (((n * p) - (m * p)) ~ ((n - m) * p)) => a) -> a-withSubMulDistribRight _n _m _p f =-  case unsafeCoerce (Refl :: 0 :~: 0) of-    (Refl :: (((n * p) - (m * p)) :~: ((n - m) * p)) ) -> f----------------------------------------------------------------------------- LeqProof---- | @LeqProof m n@ is a type whose values are only inhabited when @m@--- is less than or equal to @n@.-data LeqProof m n where-  LeqProof :: (m <= n) => LeqProof m n---- | (<=) is a decidable relation on nats.-decideLeq :: NatRepr a -> NatRepr b -> Either (LeqProof a b) ((LeqProof a b) -> Void)-decideLeq (NatRepr m) (NatRepr n)-  | m <= n    = Left $ unsafeCoerce (LeqProof :: LeqProof 0 0)-  | otherwise = Right $-      \x -> seq x $ error "Impossible [decidable <= on NatRepr]"--testStrictLeq :: forall m n-               . (m <= n)-              => NatRepr m-              -> NatRepr n-              -> Either (LeqProof (m+1) n) (m :~: n)-testStrictLeq (NatRepr m) (NatRepr n)-  | m < n = Left (unsafeCoerce (LeqProof :: LeqProof 0 0))-  | otherwise = Right (unsafeCoerce (Refl :: m :~: m))-{-# NOINLINE testStrictLeq #-}---- As for NatComparison above, but works with LeqProof-data NatCases m n where-  -- First number is less than second.-  NatCaseLT :: LeqProof (m+1) n -> NatCases m n-  NatCaseEQ :: NatCases m m-  -- First number is greater than second.-  NatCaseGT :: LeqProof (n+1) m -> NatCases m n--testNatCases ::  forall m n-              . NatRepr m-             -> NatRepr n-             -> NatCases m n-testNatCases m n =-  case compare (natValue m) (natValue n) of-    LT -> NatCaseLT (unsafeCoerce (LeqProof :: LeqProof 0 0))-    EQ -> unsafeCoerce $ (NatCaseEQ :: NatCases m m)-    GT -> NatCaseGT (unsafeCoerce (LeqProof :: LeqProof 0 0))-{-# NOINLINE testNatCases #-}---- | The strict order (<), defined by n < m <-> n + 1 <= m, is irreflexive.-lessThanIrreflexive :: forall f (a :: Nat). f a -> LeqProof (1 + a) a -> Void-lessThanIrreflexive a prf =-  let prf1 :: LeqProof (1 + a - a) (a - a)-      prf1 = leqSub2 prf (LeqProof :: LeqProof a a)-      prf2 :: 1 + a - a :~: 1-      prf2 = plusMinusCancel (knownNat @1) a-      prf3 :: a - a :~: 0-      prf3 = plusMinusCancel (knownNat @0) a-      prf4 :: LeqProof 1 0-      prf4 = case prf2 of Refl -> case prf3 of { Refl -> prf1 }-  in case prf4 of {}---- | The strict order on the naturals is irreflexive.-lessThanAsymmetric :: forall m f n-                    . LeqProof (n+1) m-                   -> LeqProof (m+1) n-                   -> f n-                   -> Void-lessThanAsymmetric nLTm mLTn n =-  case plusComm n (knownNat @1) :: n + 1 :~: 1 + n of { Refl ->-  case leqAdd (LeqProof :: LeqProof m m) (knownNat @1) :: LeqProof m (m+1) of-    LeqProof -> lessThanIrreflexive n $ leqTrans (leqTrans nLTm LeqProof) mLTn-  }---- | @x `testLeq` y@ checks whether @x@ is less than or equal to @y@.-testLeq :: forall m n . NatRepr m -> NatRepr n -> Maybe (LeqProof m n)-testLeq (NatRepr m) (NatRepr n)-   | m <= n    = Just (unsafeCoerce (LeqProof :: LeqProof 0 0))-   | otherwise = Nothing-{-# NOINLINE testLeq #-}---- | Apply reflexivity to LeqProof-leqRefl :: forall f n . f n -> LeqProof n n-leqRefl _ = LeqProof---- | Apply transitivity to LeqProof-leqTrans :: LeqProof m n -> LeqProof n p -> LeqProof m p-leqTrans LeqProof LeqProof = unsafeCoerce (LeqProof :: LeqProof 0 0)-{-# NOINLINE leqTrans #-}---- | Add both sides of two inequalities-leqAdd2 :: LeqProof x_l x_h -> LeqProof y_l y_h -> LeqProof (x_l + y_l) (x_h + y_h)-leqAdd2 x y = seq x $ seq y $ unsafeCoerce (LeqProof :: LeqProof 0 0)-{-# NOINLINE leqAdd2 #-}---- | Subtract sides of two inequalities.-leqSub2 :: LeqProof x_l x_h-        -> LeqProof y_l y_h-        -> LeqProof (x_l-y_h) (x_h-y_l)-leqSub2 LeqProof LeqProof = unsafeCoerce (LeqProof :: LeqProof 0 0)-{-# NOINLINE leqSub2 #-}----------------------------------------------------------------------------- LeqProof combinators---- | Create a leqProof using two proxies-leqProof :: (m <= n) => f m -> g n -> LeqProof m n-leqProof _ _ = LeqProof--withLeqProof :: LeqProof m n -> ((m <= n) => a) -> a-withLeqProof p a =-  case p of-    LeqProof -> a---- | Test whether natural number is positive.-isPosNat :: NatRepr n -> Maybe (LeqProof 1 n)-isPosNat = testLeq (knownNat :: NatRepr 1)---- | Congruence rule for multiplication-leqMulCongr :: LeqProof a x-            -> LeqProof b y-            -> LeqProof (a*b) (x*y)-leqMulCongr LeqProof LeqProof = unsafeCoerce (LeqProof :: LeqProof 1 1)-{-# NOINLINE leqMulCongr #-}---- | Multiplying two positive numbers results in a positive number.-leqMulPos :: forall p q x y-          .  (1 <= x, 1 <= y)-          => p x-          -> q y-          -> LeqProof 1 (x*y)-leqMulPos _ _ = leqMulCongr (LeqProof :: LeqProof 1 x) (LeqProof :: LeqProof 1 y)--leqMulMono :: (1 <= x) => p x -> q y -> LeqProof y (x * y)-leqMulMono x y = leqMulCongr (leqProof (Proxy :: Proxy 1) x) (leqRefl y)---- | Produce proof that adding a value to the larger element in an LeqProof--- is larger-leqAdd :: forall f m n p . LeqProof m n -> f p -> LeqProof m (n+p)-leqAdd x _ = leqAdd2 x (LeqProof :: LeqProof 0 p)--leqAddPos :: (1 <= m, 1 <= n) => p m -> q n -> LeqProof 1 (m + n)-leqAddPos m n = leqAdd (leqProof (Proxy :: Proxy 1) m) n---- | Produce proof that subtracting a value from the smaller element is smaller.-leqSub :: forall m n p . LeqProof m n -> LeqProof p m -> LeqProof (m-p) n-leqSub x _ = leqSub2 x (LeqProof :: LeqProof 0 p)--addIsLeq :: f n -> g m -> LeqProof n (n + m)-addIsLeq n m = leqAdd (leqRefl n) m--addPrefixIsLeq :: f m -> g n -> LeqProof n (m + n)-addPrefixIsLeq m n =-  case plusComm n m of-    Refl -> addIsLeq n m--dblPosIsPos :: forall n . LeqProof 1 n -> LeqProof 1 (n+n)-dblPosIsPos x = leqAdd x Proxy--addIsLeqLeft1 :: forall n n' m . LeqProof (n + n') m -> LeqProof n m-addIsLeqLeft1 p =-    case plusMinusCancel n n' of-      Refl -> leqSub p le-  where n :: Proxy n-        n = Proxy-        n' :: Proxy n'-        n' = Proxy-        le :: LeqProof n' (n + n')-        le = addPrefixIsLeq n n'--{-# INLINE withAddPrefixLeq #-}-withAddPrefixLeq :: NatRepr n -> NatRepr m -> ((m <= n + m) => a) -> a-withAddPrefixLeq n m = withLeqProof (addPrefixIsLeq n m)--withAddLeq :: forall n m a. NatRepr n -> NatRepr m -> ((n <= n + m) => NatRepr (n + m) -> a) -> a-withAddLeq n m f = withLeqProof (addIsLeq n m) (f (addNat n m))--natForEach' :: forall l h a-            . NatRepr l-            -> NatRepr h-            -> (forall n. LeqProof l n -> LeqProof n h -> NatRepr n -> a)-            -> [a]-natForEach' l h f-  | Just LeqProof  <- testLeq l h =-    let f' :: forall n. LeqProof (l + 1) n -> LeqProof n h -> NatRepr n -> a-        f' = \lp hp -> f (addIsLeqLeft1 lp) hp-     in f LeqProof LeqProof l : natForEach' (incNat l) h f'-  | otherwise             = []---- | Apply a function to each element in a range; return the list of values--- obtained.-natForEach :: forall l h a-            . NatRepr l-           -> NatRepr h-           -> (forall n. (l <= n, n <= h) => NatRepr n -> a)-           -> [a]-natForEach l h f = natForEach' l h (\LeqProof LeqProof -> f)---- | Apply a function to each element in a range starting at zero;--- return the list of values obtained.-natFromZero :: forall h a-            . NatRepr h-           -> (forall n. (n <= h) => NatRepr n -> a)-           -> [a]-natFromZero = natForEach (knownNat @0)---- | Recursor for natural numbeers.-natRec :: forall p f-       .  NatRepr p-       -> f 0 {- ^ base case -}-       -> (forall n. NatRepr n -> f n -> f (n + 1))-       -> f p-natRec n base ind =-  case isZeroNat n of-    ZeroNat    -> base-    NonZeroNat -> let n' = predNat n-                  in ind n' (natRec n' base ind)---- | Strong induction variant of the recursor.-natRecStrong :: forall p f-             .  NatRepr p-             -> f 0 {- ^ base case -}-             -> (forall n.-                  NatRepr n ->-                  (forall m. (m <= n) => NatRepr m -> f m) ->-                  f (n + 1)) {- ^ inductive step -}-             -> f p-natRecStrong p base ind = natRecStrong' base ind p-  where -- We can't use use "flip" or some other basic combinator-        -- because type variables can't be instantiated to contain "forall"s.-        natRecStrong' :: forall p' f'-                      .  f' 0 {- ^ base case -}-                      -> (forall n.-                            NatRepr n ->-                            (forall m. (m <= n) => NatRepr m -> f' m) ->-                            f' (n + 1)) {- ^ inductive step -}-                      -> NatRepr p'-                      -> f' p'-        natRecStrong' base' ind' n =-          case isZeroNat n of-            ZeroNat    -> base'-            NonZeroNat -> ind' (predNat n) (natRecStrong' base' ind')---- | Bounded recursor for natural numbers.------ If you can prove:--- - Base case: f 0--- - Inductive step: if n <= h and (f n) then (f (n + 1))--- You can conclude: for all n <= h, (f (n + 1)).-natRecBounded :: forall m h f. (m <= h)-              => NatRepr m-              -> NatRepr h-              -> f 0-              -> (forall n. (n <= h) => NatRepr n -> f n -> f (n + 1))-              -> f (m + 1)-natRecBounded m h base indH =-  case isZeroOrGT1 m of-    Left Refl      -> indH (knownNat @0) base-    Right LeqProof ->-      case decideLeq m h of-        Left LeqProof {- :: m <= h -} ->-          let -- Since m is non-zero, it is n + 1 for some n.-              lemma :: LeqProof (m-1) h-              lemma = leqSub (LeqProof :: LeqProof m h) (LeqProof :: LeqProof 1 m)-          in indH m $-            case lemma of { LeqProof ->-            case minusPlusCancel m (knownNat @1) of { Refl ->-              natRecBounded @(m - 1) @h @f (predNat m) h base indH-            }}-        Right f {- :: (m <= h) -> Void -} ->-          absurd $ f (LeqProof :: LeqProof m h)--mulCancelR ::-  (1 <= c, (n1 * c) ~ (n2 * c)) => f1 n1 -> f2 n2 -> f3 c -> (n1 :~: n2)-mulCancelR _ _ _ = unsafeCoerce Refl---- | Used in @Vector@-lemmaMul :: (1 <= n) => p w -> q n -> (w + (n-1) * w) :~: (n * w)-lemmaMul = unsafeCoerce Refl
− submodules/parameterized-utils/src/Data/Parameterized/Nonce.hs 
@@ -1,163 +0,0 @@-{-|-Copyright        : (c) Galois, Inc 2014-2016-Maintainer       : Joe Hendrix <jhendrix@galois.com>--This module provides a simple generator of new indexes in the ST monad.-It is predictable and not intended for cryptographic purposes.--This module also provides a global nonce generator that will generate-2^64 nonces before looping.--NOTE: The 'TestEquality' and 'OrdF' instances for the 'Nonce' type simply-compare the generated nonce values and then assert to the compiler-(via 'unsafeCoerce') that the types ascribed to the nonces are equal-if their values are equal.--}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE Trustworthy #-}-#if MIN_VERSION_base(4,9,0)-{-# LANGUAGE TypeInType #-}-#endif-module Data.Parameterized.Nonce-  ( -- * NonceGenerator-    NonceGenerator-  , freshNonce-  , countNoncesGenerated-  , Nonce-  , indexValue-    -- * Accessing a nonce generator-  , newSTNonceGenerator-  , newIONonceGenerator-  , withIONonceGenerator-  , withSTNonceGenerator-  , withGlobalSTNonceGenerator-  , GlobalNonceGenerator-  , globalNonceGenerator-  ) where--import Control.Monad.ST-import Data.Hashable-import Data.IORef-import Data.STRef-import Data.Typeable-import Data.Word-import Unsafe.Coerce-import System.IO.Unsafe (unsafePerformIO)--import Data.Parameterized.Classes-import Data.Parameterized.Some--#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ < 805-import Data.Kind-#endif---- | Provides a monadic action for getting fresh typed names.------ The first type parameter @m@ is the monad used for generating names, and--- the second parameter @s@ is used for the counter.-data NonceGenerator (m :: * -> *) (s :: *) where-  STNG :: !(STRef t Word64) -> NonceGenerator (ST t) s-  IONG :: !(IORef Word64) -> NonceGenerator IO s--#if MIN_VERSION_base(4,9,0)--- We have to make the k explicit in GHC 8.0 to avoid a warning.-freshNonce :: forall m s k (tp :: k) . NonceGenerator m s -> m (Nonce s tp)-#else-freshNonce :: forall m s (tp :: k) . NonceGenerator m s -> m (Nonce s tp)-#endif-freshNonce (IONG r) =-  atomicModifyIORef' r $ \n -> (n+1, Nonce n)-freshNonce (STNG r) = do-  i <- readSTRef r-  writeSTRef r $! i+1-  return $ Nonce i-  -- (Weirdly, there's no atomicModifySTRef'.  Yes, only the IO monad-  -- does concurrency, but the ST monad is part of the IO monad via-  -- stToIO, so there's no guarantee that ST code won't be run in-  -- multiple threads.)--{-# INLINE freshNonce #-}-  -- Inlining is particularly necessary since there's no @Monad m@-  -- constraint on 'freshNonce', so SPECIALIZE doesn't work on it.  In-  -- this case, though, we get specialization for free from inlining.-  -- For instance, a @NonceGenerator IO s@ must be an @IONG@, so the-  -- simplifier eliminates the STNG branch.---- | The number of nonces generated so far by this generator.  Only--- really useful for profiling.-countNoncesGenerated :: NonceGenerator m s -> m Integer-countNoncesGenerated (IONG r) = toInteger <$> readIORef r-countNoncesGenerated (STNG r) = toInteger <$> readSTRef r---- | Create a new counter.-withGlobalSTNonceGenerator :: (forall t . NonceGenerator (ST t) t -> ST t r) -> r-withGlobalSTNonceGenerator f = runST $ do-  r <- newSTRef (toEnum 0)-  f $! STNG r---- | Create a new nonce generator in the ST monad.-newSTNonceGenerator :: ST t (Some (NonceGenerator (ST t)))-newSTNonceGenerator = Some . STNG <$> newSTRef (toEnum 0)---- | Create a new nonce generator in the ST monad.-newIONonceGenerator :: IO (Some (NonceGenerator IO))-newIONonceGenerator = Some . IONG <$> newIORef (toEnum 0)---- | Run a ST computation with a new nonce generator in the ST monad.-withSTNonceGenerator :: (forall s . NonceGenerator (ST t) s -> (ST t) r) -> ST t r-withSTNonceGenerator f = do-  Some r <- newSTNonceGenerator-  f r---- | Create a new nonce generator in the IO monad.-withIONonceGenerator :: (forall s . NonceGenerator IO s -> IO r) -> IO r-withIONonceGenerator f = do-  Some r <- newIONonceGenerator-  f r---- | An index generated by the counter.-newtype Nonce (s :: *) (tp :: k) = Nonce { indexValue :: Word64 }-  deriving (Eq, Ord, Hashable, Show)----  Force the type role of Nonce to be nominal: this prevents Data.Coerce.coerce---  from casting the types of nonces, which it would otherwise be able to do---  because tp is a phantom type parameter.  This partially helps to protect---  the nonce abstraction.-type role Nonce nominal nominal--instance TestEquality (Nonce s) where-  testEquality x y | indexValue x == indexValue y = unsafeCoerce (Just Refl)-                   | otherwise = Nothing--instance OrdF (Nonce s) where-  compareF x y =-    case compare (indexValue x) (indexValue y) of-      LT -> LTF-      EQ -> unsafeCoerce EQF-      GT -> GTF--instance HashableF (Nonce s) where-  hashWithSaltF s (Nonce x) = hashWithSalt s x--instance ShowF (Nonce s)----------------------------------------------------------------------------- GlobalNonceGenerator--data GlobalNonceGenerator--globalNonceIORef :: IORef Word64-globalNonceIORef = unsafePerformIO (newIORef 0)-{-# NOINLINE globalNonceIORef #-}---- | A nonce generator that uses a globally-defined counter.-globalNonceGenerator :: NonceGenerator IO GlobalNonceGenerator-globalNonceGenerator = IONG globalNonceIORef
− submodules/parameterized-utils/src/Data/Parameterized/Nonce/Transformers.hs 
@@ -1,70 +0,0 @@-{-|-Copyright        : (c) Galois, Inc 2014-2016-Maintainer       : Eddy Westbrook <westbrook@galois.com>--This module provides a typeclass and monad transformers for generating-nonces.--}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-module Data.Parameterized.Nonce.Transformers-  ( MonadNonce(..)-  , NonceT(..)-  , NonceST-  , NonceIO-  , getNonceSTGen-  , runNonceST-  , runNonceIO-  , module Data.Parameterized.Nonce-  ) where--import Control.Monad.Reader-import Control.Monad.ST-import Control.Monad.State--import Data.Parameterized.Nonce----- | A 'MonadNonce' is a monad that can generate fresh 'Nonce's in a given set--- (where we view the phantom type parameter of 'Nonce' as a designator of the--- set that the 'Nonce' came from).-class Monad m => MonadNonce m where-  type NonceSet m :: *-  freshNonceM :: forall (tp :: k) . m (Nonce (NonceSet m) tp)---- | This transformer adds a nonce generator to a given monad.-newtype NonceT s m a =-  NonceT { runNonceT :: ReaderT (NonceGenerator m s) m a }-  deriving (Functor, Applicative, Monad)--instance MonadTrans (NonceT s) where-  lift m = NonceT $ lift m--instance Monad m => MonadNonce (NonceT s m) where-  type NonceSet (NonceT s m) = s-  freshNonceM = NonceT $ lift . freshNonce =<< ask--instance MonadNonce m => MonadNonce (StateT s m) where-  type NonceSet (StateT s m) = NonceSet m-  freshNonceM = lift $ freshNonceM---- | Helper type to build a 'MonadNonce' from the 'ST' monad.-type NonceST t s = NonceT s (ST t)---- | Helper type to build a 'MonadNonce' from the 'IO' monad.-type NonceIO s = NonceT s IO---- | Return the actual 'NonceGenerator' used in an 'ST' computation.-getNonceSTGen :: NonceST t s (NonceGenerator (ST t) s)-getNonceSTGen = NonceT ask---- | Run a 'NonceST' computation with a fresh 'NonceGenerator'.-runNonceST :: (forall t s. NonceST t s a) -> a-runNonceST m = runST $ withSTNonceGenerator $ runReaderT $ runNonceT m---- | Run a 'NonceIO' computation with a fresh 'NonceGenerator' inside 'IO'.-runNonceIO :: (forall s. NonceIO s a) -> IO a-runNonceIO m = withIONonceGenerator $ runReaderT $ runNonceT m
− submodules/parameterized-utils/src/Data/Parameterized/Nonce/Unsafe.hs 
@@ -1,107 +0,0 @@---------------------------------------------------------------------------- |--- Module           : Data.Parameterized.NonceGenerator--- Description      : A counter in the ST monad.--- Copyright        : (c) Galois, Inc 2014--- Maintainer       : Joe Hendrix <jhendrix@galois.com>--- Stability        : provisional------ This module provides a simple generator of new indexes in the ST monad.--- It is predictable and not intended for cryptographic purposes.------ NOTE: the 'TestEquality' and 'OrdF' instances for the 'Nonce' type simply--- compare the generated nonce values and then assert to the compiler--- (via 'unsafeCoerce') that the types ascribed to the nonces are equal--- if their values are equal.  This is only OK because of the discipline--- by which nonces should be used: they should only be generated from--- a 'NonceGenerator' (i.e., should not be built directly), and nonces from--- different generators must never be compared!  Arranging to compare--- Nonces from different origins would allow users to build 'unsafeCoerce'--- via the 'testEquality' function.------ A somewhat safer API would be to brand the generated Nonces with the--- state type variable of the NonceGenerator whence they came, and to only--- provide NonceGenerators via a Rank-2 continuation-passing API, similar to--- 'runST'. This would (via a meta-argument involving parametricity)--- help to prevent nonces of different origin from being compared.--- However, this would force us to push the 'ST' type brand into a significant--- number of other structures and APIs.------ Another alternative would be to use 'unsafePerformIO' magic to make--- a global nonce generator, and make that the only way to generate nonces.--- It is not clear that this is actually an improvement from a type safety--- point of view, but an argument could be made.------ For now, be careful using Nonces, and ensure that you do not mix--- Nonces from different NonceGenerators.--------------------------------------------------------------------------{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE Unsafe #-}-module Data.Parameterized.Nonce.Unsafe-  ( NonceGenerator-  , newNonceGenerator-  , freshNonce-  , atLimit-  , Nonce-  , indexValue-  ) where--import Control.Monad.ST-import Data.Hashable-import Data.STRef-import Data.Word-import Unsafe.Coerce--import Data.Parameterized.Classes---- | A simple type that for getting fresh indices in the 'ST' monad.--- The type parameter @s@ is used for the 'ST' monad parameter.-newtype NonceGenerator s = NonceGenerator (STRef s Word64)---- | Create a new counter.-newNonceGenerator :: ST s (NonceGenerator s)-newNonceGenerator = NonceGenerator `fmap` newSTRef (toEnum 0)---- | An index generated by the counter.-newtype Nonce (tp :: k) = Nonce { indexValue :: Word64 }-  deriving (Eq, Ord, Hashable, Show)----  Force the type role of Nonce to be nominal: this prevents Data.Coerce.coerce---  from casting the types of nonces, which it would otherwise be able to do---  because tp is a phantom type parameter.  This partially helps to protect---  the nonce abstraction.-type role Nonce nominal--instance TestEquality Nonce where-  testEquality x y | indexValue x == indexValue y = unsafeCoerce (Just Refl)-                   | otherwise = Nothing--instance OrdF Nonce where-  compareF x y =-    case compare (indexValue x) (indexValue y) of-      LT -> LTF-      EQ -> unsafeCoerce EQF-      GT -> GTF--instance HashableF Nonce where-  hashWithSaltF s (Nonce x) = hashWithSalt s x--instance ShowF Nonce--{-# INLINE freshNonce #-}--- | Get a fresh index and increment the counter.-freshNonce :: NonceGenerator s -> ST s (Nonce tp)-freshNonce (NonceGenerator r) = do-  i <- readSTRef r-  writeSTRef r $! succ i-  return (Nonce i)---- | Return true if counter has reached the limit, and can't be--- incremented without risk of error.-atLimit :: NonceGenerator s -> ST s Bool-atLimit (NonceGenerator r) = do-  i <- readSTRef r-  return (i == maxBound)
− submodules/parameterized-utils/src/Data/Parameterized/Pair.hs 
@@ -1,51 +0,0 @@-{-|-Copyright        : (c) Galois, Inc 2017--This module defines a 2-tuple where both elements are parameterized over the-same existentially quantified parameter.---}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-module Data.Parameterized.Pair-  ( Pair(..)-  , fstPair-  , sndPair-  , viewPair-  ) where--import Data.Parameterized.Classes-import Data.Parameterized.Some-import Data.Parameterized.TraversableF---- | Like a 2-tuple, but with an existentially quantified parameter that both of--- the elements share.-data Pair (a :: k -> *) (b :: k -> *) where-  Pair :: !(a tp) -> !(b tp) -> Pair a b--instance (TestEquality a, EqF b) => Eq (Pair a b) where-  Pair xa xb == Pair ya yb =-    case testEquality xa ya of-      Just Refl -> eqF xb yb-      Nothing -> False--instance FunctorF (Pair a) where-  fmapF f (Pair x y) = Pair x (f y)--instance FoldableF (Pair a) where-  foldMapF f (Pair _ y) = f y-  foldrF f z (Pair _ y) = f y z---- | Extract the first element of a pair.-fstPair :: Pair a b -> Some a-fstPair (Pair x _) = Some x---- | Extract the second element of a pair.-sndPair :: Pair a b -> Some b-sndPair (Pair _ y) = Some y---- | Project out of Pair.-viewPair :: (forall tp. a tp -> b tp -> c) -> Pair a b -> c-viewPair f (Pair x y) = f x y
− submodules/parameterized-utils/src/Data/Parameterized/Peano.hs 
@@ -1,285 +0,0 @@-{-|--This defines a type 'Peano' and 'PeanoRepr' for representing a-type-level natural at runtime. These type-level numbers are defined-inductively instead of using GHC.TypeLits.--As a result, type-level computation defined recursively over these-numbers works more smoothly. (For example, see the type-level-function Repeatn below.)--Note: as in NatRepr, the runtime representation of these type-level-natural numbers is an Int.---}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--#if MIN_VERSION_base(4,9,0)-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}-#endif-#if __GLASGOW_HASKELL__ >= 805-{-# LANGUAGE NoStarIsType #-}-#endif-module Data.Parameterized.Peano-   ( Peano-     , Z , S-     , Plus, Minus, Mul, Le, Lt, Gt, Ge, Max, Min, Repeat-     , plusP, minusP, mulP, maxP, minP, repeatP-     , zeroP, succP, predP--     , KnownPeano-     , withKnownPeano--     , PeanoRepr, peanoValue-     , PeanoView(..), peanoView-     , viewRepr--     , somePeano-     , mkPeanoRepr-     , maxPeano-     , minPeano--     -- * Re-exports-     , TestEquality(..)-     , (:~:)(..)-     , Data.Parameterized.Some.Some--     ) where--import           Data.Parameterized.Classes-import           Data.Parameterized.DecidableEq-import           Data.Parameterized.Some--import           Data.Hashable-import           Data.Constraint-import           Data.Word--import           Unsafe.Coerce(unsafeCoerce)----------------------------------------------------------------------------- ** Peano - a unary representation of natural numbers--data Peano = Z | S Peano--- | Peano zero-type Z = 'Z--- | Peano successor-type S = 'S---- Peano numbers are more about *counting* than arithmetic.--- They are most useful as iteration arguments and list indices--- However, for completeness, we define a few standard--- operations.--type family Plus (a :: Peano) (b :: Peano) :: Peano where-  Plus Z     b = b-  Plus (S a) b = S (Plus a b)--type family Minus (a :: Peano) (b :: Peano) :: Peano where-  Minus Z     b     = Z-  Minus (S a) (S b) = Minus a b-  Minus a    Z      = a--type family Mul (a :: Peano) (b :: Peano) :: Peano where-  Mul Z     b = Z-  Mul (S a) b = Plus a (Mul a b)--type family Le  (a :: Peano) (b :: Peano) :: Bool where-  Le  a  a        = 'True-  Le  Z  b        = 'True-  Le  a  Z        = 'False-  Le  (S a) (S b) = Le a b--type family Lt  (a :: Peano) (b :: Peano) :: Bool where-  Lt a b = Le (S a) b--type family Gt  (a :: Peano) (b :: Peano) :: Bool where-  Gt a b = Lt b a--type family Ge  (a :: Peano) (b :: Peano) :: Bool where-  Ge a b = Le b a--type family Max (a :: Peano) (b :: Peano) :: Peano where-  Max Z b = b-  Max a Z = a-  Max (S a) (S b) = S (Max a b)--type family Min (a :: Peano) (b :: Peano) :: Peano where-  Min Z b = Z-  Min a Z = Z-  Min (S a) (S b) = S (Min a b)---- Apply a constructor 'f' n-times to an argument 's'-type family Repeat (m :: Peano) (f :: k -> k) (s :: k) :: k where-  Repeat Z f s     = s-  Repeat (S m) f s = f (Repeat m f s)------------------------------------------------------------------------------ ** Run time representation of Peano numbers---- | The run time value, stored as an Word64--- As these are unary numbers, we don't worry about overflow.-newtype PeanoRepr (n :: Peano) =-  PeanoRepr { peanoValue :: Word64 }---- n is Phantom in the definition, but we don't want to allow coerce-type role PeanoRepr nominal---------------------------------------------------------------- | Because we have optimized the runtime representation,--- we need to have a "view" that decomposes the representation--- into the standard form.-data PeanoView (n :: Peano) where-  ZRepr :: PeanoView Z-  SRepr :: PeanoRepr n -> PeanoView (S n)---- | Test whether a number is Zero or Successor-peanoView :: PeanoRepr n -> PeanoView n-peanoView (PeanoRepr i) =-  if i == 0 then unsafeCoerce ZRepr else unsafeCoerce (SRepr (PeanoRepr (i-1)))---- | convert the view back to the runtime representation-viewRepr :: PeanoView n -> PeanoRepr n-viewRepr ZRepr     = PeanoRepr 0-viewRepr (SRepr n) = PeanoRepr (peanoValue n + 1)--------------------------------------------------------------instance Hashable (PeanoRepr n) where-  hashWithSalt i (PeanoRepr x) = hashWithSalt i x--instance Eq (PeanoRepr m) where-  _ == _ = True--instance TestEquality PeanoRepr where-  testEquality (PeanoRepr m) (PeanoRepr n)-    | m == n = Just (unsafeCoerce Refl)-    | otherwise = Nothing--instance DecidableEq PeanoRepr where-  decEq (PeanoRepr m) (PeanoRepr n)-    | m == n    = Left $ unsafeCoerce Refl-    | otherwise = Right $-        \x -> seq x $ error "Impossible [DecidableEq on PeanoRepr]"--instance OrdF PeanoRepr where-  compareF (PeanoRepr m) (PeanoRepr n)-    | m < n     = unsafeCoerce LTF-    | m == n    = unsafeCoerce EQF-    | otherwise = unsafeCoerce GTF--instance PolyEq (PeanoRepr m) (PeanoRepr n) where-  polyEqF x y = (\Refl -> Refl) <$> testEquality x y---- Display as digits, not in unary-instance Show (PeanoRepr p) where-  show p = show (peanoValue p)--instance ShowF PeanoRepr--instance HashableF PeanoRepr where-  hashWithSaltF = hashWithSalt--------------------------------------------------------------- * Implicit runtime Peano numbers--type KnownPeano = KnownRepr PeanoRepr--instance KnownRepr PeanoRepr Z where-  knownRepr = viewRepr ZRepr-instance (KnownRepr PeanoRepr n) => KnownRepr PeanoRepr (S n) where-  knownRepr = viewRepr (SRepr knownRepr)--newtype DI a = Don'tInstantiate (KnownPeano a => Dict (KnownPeano a))--peanoInstance :: forall a . PeanoRepr a -> Dict (KnownPeano a)-peanoInstance s = with_sing_i Dict-  where-    with_sing_i :: (KnownPeano a => Dict (KnownPeano a)) -> Dict (KnownPeano a)-    with_sing_i si = unsafeCoerce (Don'tInstantiate si) s---- | convert an explicit number to an implicit number-withKnownPeano :: forall n r. PeanoRepr n -> (KnownPeano n => r) -> r-withKnownPeano si r = case peanoInstance si of-                        Dict -> r--------------------------------------------------------------- * Operations on runtime numbers---- | zero-zeroP :: PeanoRepr Z-zeroP = PeanoRepr 0---- | Successor, Increment-succP :: PeanoRepr n -> PeanoRepr (S n)-succP (PeanoRepr i) = PeanoRepr (i+1)---- | Get the predecessor (decrement)-predP :: PeanoRepr (S n) -> PeanoRepr n-predP (PeanoRepr i) = PeanoRepr (i-1)---plusP :: PeanoRepr a -> PeanoRepr b -> PeanoRepr (Plus a b)-plusP (PeanoRepr a) (PeanoRepr b) = PeanoRepr (a + b)--minusP :: PeanoRepr a -> PeanoRepr b -> PeanoRepr (Minus a b)-minusP (PeanoRepr a) (PeanoRepr b) = PeanoRepr (a - b)--mulP :: PeanoRepr a -> PeanoRepr b -> PeanoRepr (Mul a b)-mulP (PeanoRepr a) (PeanoRepr b) = PeanoRepr (a * b)--maxP :: PeanoRepr a -> PeanoRepr b -> PeanoRepr (Max a b)-maxP (PeanoRepr a) (PeanoRepr b) = PeanoRepr (max a b)--minP :: PeanoRepr a -> PeanoRepr b -> PeanoRepr (Min a b)-minP (PeanoRepr a) (PeanoRepr b) = PeanoRepr (min a b)--repeatP :: PeanoRepr m -> (forall a. repr a -> repr (f a)) -> repr s -> repr (Repeat m f s)-repeatP n f s = case peanoView n of-  ZRepr   -> s-  SRepr m -> f (repeatP m f s)----------------------------------------------------------------------------- * Some PeanoRepr---- | Convert a Word64 to a PeanoRepr-mkPeanoRepr :: Word64 -> Some PeanoRepr-mkPeanoRepr n = Some (PeanoRepr n)---- | Turn an @Integral@ value into a @PeanoRepr@.  Returns @Nothing@---   if the given value is negative.-somePeano :: Integral a => a -> Maybe (Some PeanoRepr)-somePeano x | x >= 0 = Just . Some . PeanoRepr $! fromIntegral x-somePeano _ = Nothing---- | Return the maximum of two representations.-maxPeano :: PeanoRepr m -> PeanoRepr n -> Some PeanoRepr-maxPeano x y-  | peanoValue x >= peanoValue y = Some x-  | otherwise = Some y---- | Return the minimum of two representations.-minPeano :: PeanoRepr m -> PeanoRepr n -> Some PeanoRepr-minPeano x y-  | peanoValue y >= peanoValue x = Some x-  | otherwise = Some y-----------------------------------------------------------------------------  LocalWords:  PeanoRepr withKnownPeano runtime Peano unary
− submodules/parameterized-utils/src/Data/Parameterized/Some.hs 
@@ -1,59 +0,0 @@---------------------------------------------------------------------------- |--- Module           : Data.Parameterized.Some--- Copyright        : (c) Galois, Inc 2014--- Maintainer       : Joe Hendrix <jhendrix@galois.com>------ This module provides 'Some', a GADT that hides a type parameter.--------------------------------------------------------------------------{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-module Data.Parameterized.Some-  ( Some(..)-  , viewSome-  , mapSome-  , traverseSome-  , traverseSome_-  ) where--import Data.Hashable-import Data.Parameterized.Classes---data Some (f:: k -> *) = forall x . Some (f x)--instance TestEquality f => Eq (Some f) where-  Some x == Some y = isJust (testEquality x y)--instance OrdF f => Ord (Some f) where-  compare (Some x) (Some y) = toOrdering (compareF x y)--instance HashableF f => Hashable (Some f) where-  hashWithSalt s (Some x) = hashWithSaltF s x-  hash (Some x) = hashF x--instance ShowF f => Show (Some f) where-  show (Some x) = showF x---- | Project out of Some.-viewSome :: (forall tp . f tp -> r) -> Some f -> r-viewSome f (Some x) = f x---- | Apply function to inner value.-mapSome :: (forall tp . f tp -> g tp) -> Some f -> Some g-mapSome f (Some x) = Some $! f x--{-# INLINE traverseSome #-}--- | Modify the inner value.-traverseSome :: Functor m-             => (forall tp . f tp -> m (g tp))-             -> Some f-             -> m (Some g)-traverseSome f (Some x) = Some `fmap` f x--{-# INLINE traverseSome_ #-}--- | Modify the inner value.-traverseSome_ :: Functor m => (forall tp . f tp -> m ()) -> Some f -> m ()-traverseSome_ f (Some x) = (\_ -> ()) `fmap` f x
− submodules/parameterized-utils/src/Data/Parameterized/SymbolRepr.hs 
@@ -1,106 +0,0 @@-{-|-Copyright        : (c) Galois, Inc 2014-2015-Maintainer       : Joe Hendrix <jhendrix@galois.com>--This defines a type family 'SymbolRepr' for representing a type-level string-(AKA symbol) at runtime.  This can be used to branch on a type-level value.--The 'TestEquality' and 'OrdF' instances for 'SymbolRepr' are implemented using-'unsafeCoerce'.  This should be typesafe because we maintain the invariant-that the string value contained in a SymbolRepr value matches its static type.--At the type level, symbols have very few operations, so SymbolRepr-correspondingly has very few functions that manipulate them.--}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE Trustworthy #-}-module Data.Parameterized.SymbolRepr-  ( -- * SymbolRepr-    SymbolRepr-  , symbolRepr-  , knownSymbol-  , someSymbol-    -- * Re-exports-  , type GHC.Symbol-  , GHC.KnownSymbol-  ) where--import GHC.TypeLits as GHC-import Unsafe.Coerce (unsafeCoerce)--import Data.Hashable-import Data.Proxy-import qualified Data.Text as Text--import Data.Parameterized.Classes-import Data.Parameterized.Some---- | A runtime representation of a GHC type-level symbol.-newtype SymbolRepr (nm::GHC.Symbol)-  = SymbolRepr { symbolRepr :: Text.Text-                 -- ^ The underlying text representation of the symbol-               }--- INVARIANT: The contained runtime text value matches the value--- of the type level symbol.  The SymbolRepr constructor--- is not exported so we can maintain this invariant in this--- module.---- | Generate a symbol representative at runtime.  The type-level---   symbol will be abstract, as it is hidden by the 'Some' constructor.-someSymbol :: Text.Text -> Some SymbolRepr-someSymbol nm = Some (SymbolRepr nm)---- | Generate a value representative for the type level symbol.-knownSymbol :: GHC.KnownSymbol s => SymbolRepr s-knownSymbol = go Proxy-  where go :: GHC.KnownSymbol s => Proxy s -> SymbolRepr s-        go p = SymbolRepr $! packSymbol (GHC.symbolVal p)--        -- NOTE here we explicitly test that unpacking the packed text value-        -- gives the desired string.  This is to avoid pathological corner cases-        -- involving string values that have no text representation.-        packSymbol str-           | Text.unpack txt == str = txt-           | otherwise = error $ "Unrepresentable symbol! "++ str-         where txt = Text.pack str--instance (GHC.KnownSymbol s) => KnownRepr SymbolRepr s where-  knownRepr = knownSymbol--instance TestEquality SymbolRepr where-   testEquality (SymbolRepr x :: SymbolRepr x) (SymbolRepr y)-      | x == y    = Just (unsafeCoerce (Refl :: x :~: x))-      | otherwise = Nothing-instance OrdF SymbolRepr where-   compareF (SymbolRepr x :: SymbolRepr x) (SymbolRepr y)-      | x <  y    = LTF-      | x == y    = unsafeCoerce (EQF :: OrderingF x x)-      | otherwise = GTF---- These instances are trivial by the invariant--- that the contained string matches the type-level--- symbol-instance Eq (SymbolRepr x) where-   _ == _ = True-instance Ord (SymbolRepr x) where-   compare _ _ = EQ--instance HashableF SymbolRepr where-  hashWithSaltF = hashWithSalt-instance Hashable (SymbolRepr nm) where-  hashWithSalt s (SymbolRepr nm) = hashWithSalt s nm--instance Show (SymbolRepr nm) where-  show (SymbolRepr nm) = Text.unpack nm--instance ShowF SymbolRepr
− submodules/parameterized-utils/src/Data/Parameterized/TH/GADT.hs 
@@ -1,488 +0,0 @@---------------------------------------------------------------------------- |--- Module           : Data.Parameterized.TH.GADT--- Copyright        : (c) Galois, Inc 2013-2014--- Maintainer       : Joe Hendrix <jhendrix@galois.com>------ This module declares template Haskell primitives so that it is easier--- to work with GADTs that have many constructors.--------------------------------------------------------------------------{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE EmptyCase #-}-module Data.Parameterized.TH.GADT-  ( -- * Instance generators-    -- $typePatterns-  structuralEquality-  , structuralTypeEquality-  , structuralTypeOrd-  , structuralTraversal-  , structuralShowsPrec-  , structuralHash-  , PolyEq(..)-    -- * Template haskell utilities that may be useful in other contexts.-  , DataD-  , lookupDataType'-  , asTypeCon-  , conPat-  , TypePat(..)-  , dataParamTypes-  , assocTypePats-  ) where--import Control.Monad-import Data.Hashable (hashWithSalt)-import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as Set-import Language.Haskell.TH-import Language.Haskell.TH.Datatype---import Data.Parameterized.Classes----------------------------------------------------------------------------- Template Haskell utilities--type DataD = DatatypeInfo--lookupDataType' :: Name -> Q DatatypeInfo-lookupDataType' = reifyDatatype---- | Given a constructor and string, this generates a pattern for matching--- the expression, and the names of variables bound by pattern in order--- they appear in constructor.-conPat ::-  ConstructorInfo {- ^ constructor information -} ->-  String          {- ^ generated name prefix   -} ->-  Q (Pat, [Name]) {- ^ pattern and bound names -}-conPat con pre = do-  nms <- newNames pre (length (constructorFields con))-  return (ConP (constructorName con) (VarP <$> nms), nms)----- | Return an expression corresponding to the constructor.--- Note that this will have the type of a function expecting--- the argumetns given.-conExpr :: ConstructorInfo -> Exp-conExpr = ConE . constructorName----------------------------------------------------------------------------- TypePat---- | A type used to describe (and match) types appearing in generated pattern--- matches inside of the TH generators in this module ('structuralEquality',--- 'structuralTypeEquality', 'structuralTypeOrd', and 'structuralTraversal')-data TypePat-   = TypeApp TypePat TypePat -- ^ The application of a type.-   | AnyType       -- ^ Match any type.-   | DataArg Int   -- ^ Match the ith argument of the data type we are traversing.-   | ConType TypeQ -- ^ Match a ground type.--matchTypePat :: [Type] -> TypePat -> Type -> Q Bool-matchTypePat d (TypeApp p q) (AppT x y) = do-  r <- matchTypePat d p x-  case r of-    True -> matchTypePat d q y-    False -> return False-matchTypePat _ AnyType _ = return True-matchTypePat tps (DataArg i) tp-  | i < 0 || i > length tps = error $ "Illegal type pattern index " ++ show i-  | otherwise = do-    return $ stripSigT (tps !! i) == tp-  where-    -- th-abstraction can annotate type parameters with their kinds,-    -- we ignore these for matching-    stripSigT (SigT t _) = t-    stripSigT t          = t-matchTypePat _ (ConType tpq) tp = do-  tp' <- tpq-  return (tp' == tp)-matchTypePat _ _ _ = return False--dataParamTypes :: DatatypeInfo -> [Type]-dataParamTypes = datatypeVars---- | Find value associated with first pattern that matches given pat if any.-assocTypePats :: [Type] -> [(TypePat,v)] -> Type -> Q (Maybe v)-assocTypePats _ [] _ = return Nothing-assocTypePats dTypes ((p,v):pats) tp = do-  r <- matchTypePat dTypes p tp-  case r of-    True -> return (Just v)-    False -> assocTypePats dTypes pats tp----------------------------------------------------------------------------- Contructor cases--typeVars :: TypeSubstitution a => a -> Set Name-typeVars = Set.fromList . freeVariables----- | @structuralEquality@ declares a structural equality predicate.-structuralEquality :: TypeQ -> [(TypePat,ExpQ)] -> ExpQ-structuralEquality tpq pats =-  [| \x y -> isJust ($(structuralTypeEquality tpq pats) x y) |]--joinEqMaybe :: Name -> Name -> ExpQ -> ExpQ-joinEqMaybe x y r = do-  [| if $(varE x) == $(varE y) then $(r) else Nothing |]--joinTestEquality :: ExpQ -> Name -> Name -> ExpQ -> ExpQ-joinTestEquality f x y r =-  [| case $(f) $(varE x) $(varE y) of-      Nothing -> Nothing-      Just Refl -> $(r)-   |]--matchEqArguments :: [Type]-                    -- ^ Types bound by data arguments.-                  -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments-                 -> Name-                     -- ^ Name of constructor.-                 -> Set Name-                 -> [Type]-                 -> [Name]-                 -> [Name]-                 -> ExpQ-matchEqArguments dTypes pats cnm bnd (tp:tpl) (x:xl) (y:yl) = do-  doesMatch <- assocTypePats dTypes pats tp-  case doesMatch of-    Just q -> do-      let bnd' =-            case tp of-              AppT _ (VarT nm) -> Set.insert nm bnd-              _ -> bnd-      joinTestEquality q x y (matchEqArguments dTypes pats cnm bnd' tpl xl yl)-    Nothing | typeVars tp `Set.isSubsetOf` bnd -> do-      joinEqMaybe x y        (matchEqArguments dTypes pats cnm bnd  tpl xl yl)-    Nothing -> do-      fail $ "Unsupported argument type " ++ show tp-          ++ " in " ++ show (ppr cnm) ++ "."-matchEqArguments _ _ _ _ [] [] [] = [| Just Refl |]-matchEqArguments _ _ _ _ [] _  _  = error "Unexpected end of types."-matchEqArguments _ _ _ _ _  [] _  = error "Unexpected end of names."-matchEqArguments _ _ _ _ _  _  [] = error "Unexpected end of names."--mkSimpleEqF :: [Type] -- ^ Data declaration types-            -> Set Name-             -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments-             -> ConstructorInfo-             -> [Name]-             -> ExpQ-             -> Bool -- ^ wildcard case required-             -> ExpQ-mkSimpleEqF dTypes bnd pats con xv yQ multipleCases = do-  -- Get argument types for constructor.-  let nm = constructorName con-  (yp,yv) <- conPat con "y"-  let rv = matchEqArguments dTypes pats nm bnd (constructorFields con) xv yv-  caseE yQ $ match (pure yp) (normalB rv) []-           : [ match wildP (normalB [| Nothing |]) [] | multipleCases ]---- | Match equational form.-mkEqF :: DatatypeInfo -- ^ Data declaration.-      -> [(TypePat,ExpQ)]-      -> ConstructorInfo-      -> [Name]-      -> ExpQ-      -> Bool -- ^ wildcard case required-      -> ExpQ-mkEqF d pats con =-  let dVars = datatypeVars d-      bnd | null dVars = Set.empty-          | otherwise  = typeVars (init dVars)-  in mkSimpleEqF dVars bnd pats con---- | @structuralTypeEquality f@ returns a function with the type:---   forall x y . f x -> f y -> Maybe (x :~: y)-structuralTypeEquality :: TypeQ -> [(TypePat,ExpQ)] -> ExpQ-structuralTypeEquality tpq pats = do-  d <- reifyDatatype =<< asTypeCon "structuralTypeEquality" =<< tpq--  let multipleCons = not (null (drop 1 (datatypeCons d)))-      trueEqs yQ = [ do (xp,xv) <- conPat con "x"-                        match (pure xp) (normalB (mkEqF d pats con xv yQ multipleCons)) []-                   | con <- datatypeCons d-                   ]--  if null (datatypeCons d)-    then [| \x -> case x of {} |]-    else [| \x y -> $(caseE [| x |] (trueEqs [| y |])) |]---- | @structuralTypeOrd f@ returns a function with the type:---   forall x y . f x -> f y -> OrderingF x y------ This implementation avoids matching on both the first and second--- parameters in a simple case expression in order to avoid stressing--- GHC's coverage checker. In the case that the first and second parameters--- have unique constructors, a simple numeric comparison is done to--- compute the result.-structuralTypeOrd ::-  TypeQ ->-  [(TypePat,ExpQ)] {- ^ List of type patterns to match. -} ->-  ExpQ-structuralTypeOrd tpq l = do-  d <- reifyDatatype =<< asTypeCon "structuralTypeEquality" =<< tpq--  let withNumber :: ExpQ -> (Maybe ExpQ -> ExpQ) -> ExpQ-      withNumber yQ k-        | null (drop 1 (datatypeCons d)) = k Nothing-        | otherwise =  [| let yn :: Int-                              yn = $(caseE yQ (constructorNumberMatches (datatypeCons d)))-                          in $(k (Just [| yn |])) |]--  if null (datatypeCons d)-    then [| \x -> case x of {} |]-    else [| \x y -> $(withNumber [|y|] $ \mbYn -> caseE [| x |] (outerOrdMatches d [|y|] mbYn)) |]-  where-    constructorNumberMatches :: [ConstructorInfo] -> [MatchQ]-    constructorNumberMatches cons =-      [ match (recP (constructorName con) [])-              (normalB (litE (integerL i)))-              []-      | (i,con) <- zip [0..] cons ]--    outerOrdMatches :: DatatypeInfo -> ExpQ -> Maybe ExpQ -> [MatchQ]-    outerOrdMatches d yExp mbYn =-      [ do (pat,xv) <- conPat con "x"-           match (pure pat)-                 (normalB (do xs <- mkOrdF d l con i mbYn xv-                              caseE yExp xs))-                 []-      | (i,con) <- zip [0..] (datatypeCons d) ]---- | Generate a list of fresh names using the base name--- numbered 1 to n to make them useful in conjunction with--- @-dsuppress-unqiues@.-newNames ::-  String   {- ^ base name                     -} ->-  Int      {- ^ quantity                      -} ->-  Q [Name] {- ^ list of names: base1, base2.. -}-newNames base n = traverse (\i -> newName (base ++ show i)) [1..n]---joinCompareF :: ExpQ -> Name -> Name -> ExpQ -> ExpQ-joinCompareF f x y r = do-  [| case $(f) $(varE x) $(varE y) of-      LTF -> LTF-      GTF -> GTF-      EQF -> $(r)-   |]---- | Compare two variables and use following comparison if they are different.------ This returns an 'OrdF' instance.-joinCompareToOrdF :: Name -> Name -> ExpQ -> ExpQ-joinCompareToOrdF x y r =-  [| case compare $(varE x) $(varE y) of-      LT -> LTF-      GT -> GTF-      EQ -> $(r)-   |]--  -- Match expression with given type to variables-matchOrdArguments :: [Type]-                     -- ^ Types bound by data arguments-                  -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments-                  -> Name-                     -- ^ Name of constructor.-                  -> Set Name-                    -- ^ Names bound in data declaration-                  -> [Type]-                     -- ^ Types for constructors-                  -> [Name]-                     -- ^ Variables bound in first pattern-                  -> [Name]-                     -- ^ Variables bound in second pattern-                  -> ExpQ-matchOrdArguments dTypes pats cnm bnd (tp : tpl) (x:xl) (y:yl) = do-  doesMatch <- assocTypePats dTypes pats tp-  case doesMatch of-    Just f -> do-      let bnd' = case tp of-                   AppT _ (VarT nm) -> Set.insert nm bnd-                   _ -> bnd-      joinCompareF f x y (matchOrdArguments dTypes pats cnm bnd' tpl xl yl)-    Nothing | typeVars tp `Set.isSubsetOf` bnd -> do-      joinCompareToOrdF x y (matchOrdArguments dTypes pats cnm bnd tpl xl yl)-    Nothing ->-      fail $ "Unsupported argument type " ++ show (ppr tp)-             ++ " in " ++ show (ppr cnm) ++ "."-matchOrdArguments _ _ _ _ [] [] [] = [| EQF |]-matchOrdArguments _ _ _ _ [] _  _  = error "Unexpected end of types."-matchOrdArguments _ _ _ _ _  [] _  = error "Unexpected end of names."-matchOrdArguments _ _ _ _ _  _  [] = error "Unexpected end of names."--mkSimpleOrdF :: [Type] -- ^ Data declaration types-             -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments-             -> ConstructorInfo -- ^ Information about the second constructor-             -> Integer -- ^ First constructor's index-             -> Maybe ExpQ -- ^ Optional second constructor's index-             -> [Name]  -- ^ Name from first pattern-             -> Q [MatchQ]-mkSimpleOrdF dTypes pats con xnum mbYn xv = do-  (yp,yv) <- conPat con "y"-  let rv = matchOrdArguments dTypes pats (constructorName con) Set.empty (constructorFields con) xv yv-  -- Return match expression-  return $ match (pure yp) (normalB rv) []-         : case mbYn of-             Nothing -> []-             Just yn -> [match wildP (normalB [| if xnum < $yn then LTF else GTF |]) []]---- | Match equational form.-mkOrdF :: DatatypeInfo -- ^ Data declaration.-       -> [(TypePat,ExpQ)] -- ^ Patterns for matching arguments-       -> ConstructorInfo-       -> Integer-       -> Maybe ExpQ -- ^ optional right constructr index-       -> [Name]-       -> Q [MatchQ]-mkOrdF d pats = mkSimpleOrdF (datatypeVars d) pats---- | Find the first recurseArg f var tp@ applies @f@ to @var@ where @var@ has type @tp@.-recurseArg :: (Type -> Q (Maybe ExpQ))-           -> ExpQ -- ^ Function to apply-           -> ExpQ-           -> Type-           -> Q (Maybe Exp)-recurseArg m f v tp = do-  mr <- m tp-  case mr of-    Just g ->  Just <$> [| $(g) $(f) $(v) |]-    Nothing ->-      case tp of-        AppT (ConT _) (AppT (VarT _) _) -> Just <$> [| traverse $(f) $(v) |]-        AppT (VarT _) _ -> Just <$> [| $(f) $(v) |]-        _ -> return Nothing---- | @traverseAppMatch f c@ builds a case statement that matches a term with--- the constructor @c@ and applies @f@ to each argument.-traverseAppMatch :: (Type -> Q (Maybe ExpQ)) -- Pattern match function-                 -> ExpQ -- ^ Function to apply to each argument recursively.-                 -> ConstructorInfo -- ^ Constructor to match.-                 -> MatchQ -- ^ Match expression that-traverseAppMatch pats fv c0 = do-  (pat,patArgs) <- conPat c0 "p"-  exprs <- zipWithM (recurseArg pats fv) (varE <$> patArgs) (constructorFields c0)--  let mkRes :: ExpQ -> [(Name, Maybe Exp)] -> ExpQ-      mkRes e [] = e-      mkRes e ((v,Nothing):r) =-        mkRes (appE e (varE v)) r-      mkRes e ((_,Just{}):r) = do-        v <- newName "r"-        lamE [varP v] (mkRes (appE e (varE v)) r)--  -- Apply the remaining argument to the expression in list.-  let applyRest :: ExpQ -> [Exp] -> ExpQ-      applyRest e [] = e-      applyRest e (a:r) = applyRest [| $(e) <*> $(pure a) |] r--  -- Apply the first argument to the list-  let applyFirst :: ExpQ -> [Exp] -> ExpQ-      applyFirst e [] = [| pure $(e) |]-      applyFirst e (a:r) = applyRest [| $(e) <$> $(pure a) |] r--  let pargs = patArgs `zip` exprs-  let rhs = applyFirst (mkRes (pure (conExpr c0)) pargs) (catMaybes exprs)-  match (pure pat) (normalB rhs) []---- | @structuralTraversal tp@ generates a function that applies--- a traversal @f@ to the subterms with free variables in @tp@.-structuralTraversal :: TypeQ -> [(TypePat, ExpQ)] -> ExpQ-structuralTraversal tpq pats0 = do-  d <- reifyDatatype =<< asTypeCon "structuralTraversal" =<< tpq-  f <- newName "f"-  a <- newName "a"-  lamE [varP f, varP a] $-      caseE (varE a)-      (traverseAppMatch (assocTypePats (datatypeVars d) pats0) (varE f) <$> datatypeCons d)--asTypeCon :: Monad m => String -> Type -> m Name-asTypeCon _ (ConT nm) = return nm-asTypeCon fn _ = fail $ fn ++ " expected type constructor."---- | @structuralHash tp@ generates a function with the type--- @Int -> tp -> Int@ that hashes type.-structuralHash :: TypeQ -> ExpQ-structuralHash tpq = do-  d <- reifyDatatype =<< asTypeCon "structuralHash" =<< tpq-  s <- newName "s"-  a <- newName "a"-  lamE [varP s, varP a] $-    caseE (varE a) (zipWith (matchHashCtor (varE s)) [0..] (datatypeCons d))--matchHashCtor :: ExpQ -> Integer  -> ConstructorInfo -> MatchQ-matchHashCtor s0 i c = do-  (pat,vars) <- conPat c "x"-  let args = [| $(litE (IntegerL i)) :: Int |] : (varE <$> vars)-  let go s e = [| hashWithSalt $(s) $(e) |]-  let rhs = foldl go s0 args-  match (pure pat) (normalB rhs) []---- | @structuralShow tp@ generates a function with the type--- @tp -> ShowS@ that shows the constructor.-structuralShowsPrec :: TypeQ -> ExpQ-structuralShowsPrec tpq = do-  d <- reifyDatatype =<< asTypeCon "structuralShowPrec" =<< tpq-  p <- newName "_p"-  a <- newName "a"-  lamE [varP p, varP a] $-    caseE (varE a) (matchShowCtor (varE p) <$> datatypeCons d)--showCon :: ExpQ -> Name -> Int -> MatchQ-showCon p nm n = do-  vars <- newNames "x" n-  let pat = ConP nm (VarP <$> vars)-  let go s e = [| $(s) . showChar ' ' . showsPrec 10 $(varE e) |]-  let ctor = [| showString $(return (LitE (StringL (nameBase nm)))) |]-  let rhs | null vars = ctor-          | otherwise = [| showParen ($(p) >= 10) $(foldl go ctor vars) |]-  match (pure pat) (normalB rhs) []--matchShowCtor :: ExpQ -> ConstructorInfo -> MatchQ-matchShowCtor p con = showCon p (constructorName con) (length (constructorFields con))---- $typePatterns------ The Template Haskell instance generators 'structuralEquality',--- 'structuralTypeEquality', 'structuralTypeOrd', and 'structuralTraversal'--- employ heuristics to generate valid instances in the majority of cases.  Most--- failures in the heuristics occur on sub-terms that are type indexed.  To--- handle cases where these functions fail to produce a valid instance, they--- take a list of exceptions in the form of their second parameter, which has--- type @[('TypePat', 'ExpQ')]@.  Each 'TypePat' is a /matcher/ that tells the--- TH generator to use the 'ExpQ' to process the matched sub-term.  Consider the--- following example:------ > data T a b where--- >   C1 :: NatRepr n -> T () n--- >--- > instance TestEquality (T a) where--- >   testEquality = $(structuralTypeEquality [t|T|]--- >                    [ (ConType [t|NatRepr|] `TypeApp` AnyType, [|testEquality|])--- >                    ])------ The exception list says that 'structuralTypeEquality' should use--- 'testEquality' to compare any sub-terms of type @'NatRepr' n@ in a value of--- type @T@.------ * 'AnyType' means that the type parameter in that position can be instantiated as any type------ * @'DataArg' n@ means that the type parameter in that position is the @n@-th---   type parameter of the GADT being traversed (@T@ in the example)------ * 'TypeApp' is type application------ * 'ConType' specifies a base type------ The exception list could have equivalently (and more precisely) have been specified as:------ > [(ConType [t|NatRepr|] `TypeApp` DataArg 1, [|testEquality|])]------ The use of 'DataArg' says that the type parameter of the 'NatRepr' must--- be the same as the second type parameter of @T@.
− submodules/parameterized-utils/src/Data/Parameterized/TestEquality.hs 
@@ -1,36 +0,0 @@-{-|-Copyright        : (c) Galois, Inc 2014-2018-Maintainer       : Langston Barrett <langston@galois.com--Utilities for working with "Data.Type.TestEquality".--NB: This module contains an orphan instance.--}--{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}--import Data.Functor.Compose-import Data.Type.Equality--testEqualityComposeBare :: forall f g x y.-                           (forall w z. f w -> f z -> Maybe (w :~: z))-                        -> Compose f g x-                        -> Compose f g y-                        -> Maybe (x :~: y)-testEqualityComposeBare testEquality_ (Compose x) (Compose y) =-  case (testEquality_ x y :: Maybe (g x :~: g y)) of-    Just Refl -> Just (Refl :: x :~: y)-    Nothing   -> Nothing--testEqualityCompose :: forall f g x y. (TestEquality f)-                    => Compose f g x-                    -> Compose f g y-                    -> Maybe (x :~: y)-testEqualityCompose = testEqualityComposeBare testEquality---- | The deduction (via generativity) that if @g x :~: g y@ then @x :~: y@.-instance (TestEquality f) => TestEquality (Compose f g) where-  testEquality = testEqualityCompose
− submodules/parameterized-utils/src/Data/Parameterized/TraversableF.hs 
@@ -1,146 +0,0 @@---------------------------------------------------------------------------- |--- Module           : Data.Parameterized.TraversableF--- Copyright        : (c) Galois, Inc 2014-2015--- Maintainer       : Joe Hendrix <jhendrix@galois.com>------ This module declares classes for working with structures that accept--- a single parametric type parameter.--------------------------------------------------------------------------{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Trustworthy #-}-module Data.Parameterized.TraversableF-  ( FunctorF(..)-  , FoldableF(..)-  , TraversableF(..)-  , traverseF_-  , fmapFDefault-  , foldMapFDefault-  , allF-  , anyF-  ) where--import Control.Applicative-import Control.Monad.Identity-import Data.Coerce-import Data.Functor.Compose (Compose(..))-import Data.Monoid-import GHC.Exts (build)--import Data.Parameterized.TraversableFC---- | A parameterized type that is a functor on all instances.-class FunctorF m where-  fmapF :: (forall x . f x -> g x) -> m f -> m g--instance FunctorF (Const x) where-  fmapF _ = coerce----------------------------------------------------------------------------- FoldableF---- | This is a coercion used to avoid overhead associated--- with function composition.-(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)-(#.) _f = coerce---- | This is a generalization of the @Foldable@ class to--- structures over parameterized terms.-class FoldableF (t :: (k -> *) -> *) where-  {-# MINIMAL foldMapF | foldrF #-}--  -- | Map each element of the structure to a monoid,-  -- and combine the results.-  foldMapF :: Monoid m => (forall s . e s -> m) -> t e -> m-  foldMapF f = foldrF (mappend . f) mempty--  -- | Right-associative fold of a structure.-  foldrF :: (forall s . e s -> b -> b) -> b -> t e -> b-  foldrF f z t = appEndo (foldMapF (Endo #. f) t) z--  -- | Left-associative fold of a structure.-  foldlF :: (forall s . b -> e s -> b) -> b -> t e -> b-  foldlF f z t = appEndo (getDual (foldMapF (\e -> Dual (Endo (\r -> f r e))) t)) z--  -- | Right-associative fold of a structure,-  -- but with strict application of the operator.-  foldrF' :: (forall s . e s -> b -> b) -> b -> t e -> b-  foldrF' f0 z0 xs = foldlF (f' f0) id xs z0-    where f' f k x z = k $! f x z--  -- | Left-associative fold of a parameterized structure-  -- with a strict accumulator.-  foldlF' :: (forall s . b -> e s -> b) -> b -> t e -> b-  foldlF' f0 z0 xs = foldrF (f' f0) id xs z0-    where f' f x k z = k $! f z x--  -- | Convert structure to list.-  toListF :: (forall tp . f tp -> a) -> t f -> [a]-  toListF f t = build (\c n -> foldrF (\e v -> c (f e) v) n t)---- | Return 'True' if all values satisfy predicate.-allF :: FoldableF t => (forall tp . f tp -> Bool) -> t f -> Bool-allF p = getAll #. foldMapF (All #. p)---- | Return 'True' if any values satisfy predicate.-anyF :: FoldableF t => (forall tp . f tp -> Bool) -> t f -> Bool-anyF p = getAny #. foldMapF (Any #. p)--instance FoldableF (Const x) where-  foldMapF _ _ = mempty----------------------------------------------------------------------------- TraversableF--class (FunctorF t, FoldableF t) => TraversableF t where-  traverseF :: Applicative m-            => (forall s . e s -> m (f s))-            -> t e-            -> m (t f)--instance TraversableF (Const x) where-  traverseF _ (Const x) = pure (Const x)---- | This function may be used as a value for `fmapF` in a `FunctorF`--- instance.-fmapFDefault :: TraversableF t => (forall s . e s -> f s) -> t e -> t f-fmapFDefault f = runIdentity #. traverseF (Identity #. f)-{-# INLINE fmapFDefault #-}---- | This function may be used as a value for `Data.Foldable.foldMap`--- in a `Foldable` instance.-foldMapFDefault :: (TraversableF t, Monoid m) => (forall s . e s -> m) -> t e -> m-foldMapFDefault f = getConst #. traverseF (Const #. f)---- | Map each element of a structure to an action, evaluate--- these actions from left to right, and ignore the results.-traverseF_ :: (FoldableF t, Applicative f) => (forall s . e s  -> f a) -> t e -> f ()-traverseF_ f = foldrF (\e r -> f e *> r) (pure ())----------------------------------------------------------------------------- TraversableF (Compose s t)--instance ( FunctorF (s :: (k -> *) -> *)-         , FunctorFC (t :: (l -> *) -> (k -> *))-         ) =>-         FunctorF (Compose s t) where-  fmapF f (Compose v) = Compose $ fmapF (fmapFC f) v--instance ( TraversableF (s :: (k -> *) -> *)-         , TraversableFC (t :: (l -> *) -> (k -> *))-         ) =>-         FoldableF (Compose s t) where-  foldMapF = foldMapFDefault---- | Traverse twice over: go under the @t@, under the @s@ and lift @m@ out.-instance ( TraversableF (s :: (k -> *) -> *)-         , TraversableFC (t :: (l -> *) -> (k -> *))-         ) =>-         TraversableF (Compose s t) where-  traverseF :: forall (f :: l -> *) (g :: l -> *) m. (Applicative m) =>-               (forall (u :: l). f u -> m (g u))-            -> Compose s t f -> m (Compose s t g)-  traverseF f (Compose v) = Compose <$> traverseF (traverseFC f) v
− submodules/parameterized-utils/src/Data/Parameterized/TraversableFC.hs 
@@ -1,161 +0,0 @@---------------------------------------------------------------------------- |--- Module           : Data.Parameterized.TraversableFC--- Copyright        : (c) Galois, Inc 2014-2015--- Maintainer       : Joe Hendrix <jhendrix@galois.com>------ This module declares classes for working with structures that accept--- a parametric type parameter followed by some fixed kind.--------------------------------------------------------------------------{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeOperators #-}-module Data.Parameterized.TraversableFC-  ( TestEqualityFC(..)-  , OrdFC(..)-  , ShowFC(..)-  , HashableFC(..)-  , FunctorFC(..)-  , FoldableFC(..)-  , TraversableFC(..)-  , traverseFC_-  , forMFC_-  , fmapFCDefault-  , foldMapFCDefault-  , allFC-  , anyFC-  , lengthFC-  ) where--import Control.Applicative (Const(..) )-import Control.Monad.Identity ( Identity (..) )-import Data.Coerce-import Data.Monoid-import GHC.Exts (build)-import Data.Type.Equality--import Data.Parameterized.Classes---- | A parameterized type that is a function on all instances.-class FunctorFC (t :: (k -> *) -> l -> *) where-  fmapFC :: forall f g. (forall x. f x -> g x) ->-                        (forall x. t f x -> t g x)---- | A parameterized class for types which can be shown, when given---   functions to show parameterized subterms.-class ShowFC (t :: (k -> *) -> l -> *) where-  {-# MINIMAL showFC | showsPrecFC #-}--  showFC :: forall f. (forall x. f x -> String)-         -> (forall x. t f x -> String)-  showFC sh x = showsPrecFC (\_prec z rest -> sh z ++ rest) 0 x []--  showsPrecFC :: forall f. (forall x. Int -> f x -> ShowS) ->-                           (forall x. Int -> t f x -> ShowS)-  showsPrecFC sh _prec x rest = showFC (\z -> sh 0 z []) x ++ rest----- | A parameterized class for types which can be hashed, when given---   functions to hash parameterized subterms.-class HashableFC (t :: (k -> *) -> l -> *) where-  hashWithSaltFC :: forall f. (forall x. Int -> f x -> Int) ->-                              (forall x. Int -> t f x -> Int)---- | A parameterized class for types which can be tested for parameterized equality,---   when given an equality test for subterms.-class TestEqualityFC (t :: (k -> *) -> l -> *) where-  testEqualityFC :: forall f. (forall x y. f x -> f y -> (Maybe (x :~: y))) ->-                              (forall x y. t f x -> t f y -> (Maybe (x :~: y)))---- | A parameterized class for types which can be tested for parameterized ordering,---   when given an comparison test for subterms.-class TestEqualityFC t => OrdFC (t :: (k -> *) -> l -> *) where-  compareFC :: forall f. (forall x y. f x -> f y -> OrderingF x y) ->-                         (forall x y. t f x -> t f y -> OrderingF x y)----------------------------------------------------------------------------- FoldableF---- | This is a coercision used to avoid overhead associated--- with function composition.-(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)-(#.) _f = coerce---- | This is a generalization of the @Foldable@ class to--- structures over parameterized terms.-class FoldableFC (t :: (k -> *) -> l -> *) where-  {-# MINIMAL foldMapFC | foldrFC #-}--  -- | Map each element of the structure to a monoid,-  -- and combine the results.-  foldMapFC :: forall f m. Monoid m => (forall x. f x -> m) -> (forall x. t f x -> m)-  foldMapFC f = foldrFC (mappend . f) mempty--  -- | Right-associative fold of a structure.-  foldrFC :: forall f b. (forall x. f x -> b -> b) -> (forall x. b -> t f x -> b)-  foldrFC f z t = appEndo (foldMapFC (Endo #. f) t) z--  -- | Left-associative fold of a structure.-  foldlFC :: forall f b. (forall x. b -> f x -> b) -> (forall x. b -> t f x -> b)-  foldlFC f z t = appEndo (getDual (foldMapFC (\e -> Dual (Endo (\r -> f r e))) t)) z--  -- | Right-associative fold of a structure,-  -- but with strict application of the operator.-  foldrFC' :: forall f b. (forall x. f x -> b -> b) -> (forall x. b -> t f x -> b)-  foldrFC' f0 z0 xs = foldlFC (f' f0) id xs z0-    where f' f k x z = k $! f x z--  -- | Left-associative fold of a parameterized structure-  -- with a strict accumulator.-  foldlFC' :: forall f b. (forall x. b -> f x -> b) -> (forall x. b -> t f x -> b)-  foldlFC' f0 z0 xs = foldrFC (f' f0) id xs z0-    where f' f x k z = k $! f z x--  -- | Convert structure to list.-  toListFC :: forall f a. (forall x. f x -> a) -> (forall x. t f x -> [a])-  toListFC f t = build (\c n -> foldrFC (\e v -> c (f e) v) n t)---- | Return 'True' if all values satisfy predicate.-allFC :: FoldableFC t => (forall x. f x -> Bool) -> (forall x. t f x -> Bool)-allFC p = getAll #. foldMapFC (All #. p)---- | Return 'True' if any values satisfy predicate.-anyFC :: FoldableFC t => (forall x. f x -> Bool) -> (forall x. t f x -> Bool)-anyFC p = getAny #. foldMapFC (Any #. p)---- | Return number of elements in list.-lengthFC :: FoldableFC t => t f x -> Int-lengthFC = foldrFC (const (+1)) 0----------------------------------------------------------------------------- TraversableF--class (FunctorFC t, FoldableFC t) => TraversableFC (t :: (k -> *) -> l -> *) where-  traverseFC :: forall f g m. Applicative m-             => (forall x. f x -> m (g x))-             -> (forall x. t f x -> m (t g x))---- | This function may be used as a value for `fmapF` in a `FunctorF`--- instance.-fmapFCDefault :: TraversableFC t => forall f g. (forall x. f x -> g x) -> (forall x. t f x -> t g x)-fmapFCDefault = \f -> runIdentity . traverseFC (Identity . f)-{-# INLINE fmapFCDefault #-}---- | This function may be used as a value for `Data.Foldable.foldMap`--- in a `Foldable` instance.-foldMapFCDefault :: (TraversableFC t, Monoid m) => (forall x. f x -> m) -> (forall x. t f x -> m)-foldMapFCDefault = \f -> getConst . traverseFC (Const . f)-{-# INLINE foldMapFCDefault #-}---- | Map each element of a structure to an action, evaluate--- these actions from left to right, and ignore the results.-traverseFC_ :: (FoldableFC t, Applicative m) => (forall x. f x -> m a) -> (forall x. t f x -> m ())-traverseFC_ f = foldrFC (\e r -> f e *> r) (pure ())-{-# INLINE traverseFC_ #-}---- | Map each element of a structure to an action, evaluate--- these actions from left to right, and ignore the results.-forMFC_ :: (FoldableFC t, Applicative m) => t f c -> (forall x. f x -> m a) -> m ()-forMFC_ v f = traverseFC_ f v-{-# INLINE forMFC_ #-}
− submodules/parameterized-utils/src/Data/Parameterized/Utils/BinTree.hs 
@@ -1,368 +0,0 @@-{-|-Description      : Utilities for balanced binary trees.-Copyright        : (c) Galois, Inc 2014-Maintainer       : Joe Hendrix <jhendrix@galois.com>--}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE Safe #-}-module Data.Parameterized.Utils.BinTree-  ( MaybeS(..)-  , fromMaybeS-  , Updated(..)-  , updatedValue-  , TreeApp(..)-  , IsBinTree(..)-  , balanceL-  , balanceR-  , glue-  , merge-  , filterGt-  , filterLt-  , insert-  , delete-  , union-  , link-  , PairS(..)-  ) where--import Control.Applicative----------------------------------------------------------------------------- MaybeS---- | A strict version of 'Maybe'-data MaybeS v-   = JustS !v-   | NothingS--instance Functor MaybeS where-  fmap _ NothingS = NothingS-  fmap f (JustS v) = JustS (f v)--instance Alternative MaybeS where-  empty = NothingS-  mv@JustS{} <|> _ = mv-  NothingS <|> v = v--instance Applicative MaybeS where-  pure = JustS--  NothingS <*> _ = NothingS-  JustS{} <*> NothingS = NothingS-  JustS f <*> JustS x = JustS (f x)--fromMaybeS :: a -> MaybeS a -> a-fromMaybeS r NothingS = r-fromMaybeS _ (JustS v) = v----------------------------------------------------------------------------- Updated---- | Updated a contains a value that has been flagged on whether it was--- modified by an operation.-data Updated a-   = Updated   !a-   | Unchanged !a--updatedValue :: Updated a -> a-updatedValue (Updated a) = a-updatedValue (Unchanged a) = a----------------------------------------------------------------------------- IsBinTree--data TreeApp e t-   = BinTree !e !t !t-   | TipTree--class IsBinTree t e | t -> e where-  asBin :: t -> TreeApp e t-  tip :: t--  bin :: e -> t -> t -> t-  size :: t -> Int--delta,ratio :: Int-delta = 3-ratio = 2---- `balanceL p l r` returns a balanced tree for the sequence @l ++ [p] ++ r@.------ It assumes that @l@ and @r@ are close to being balanced, and that only--- @l@ may contain too many elements.-balanceL :: (IsBinTree c e) => e -> c -> c -> c-balanceL p l r = do-  case asBin l of-    BinTree l_pair ll lr | size l > max 1 (delta*size r) ->-      case asBin lr of-        BinTree lr_pair lrl lrr | size lr >= max 2 (ratio*size ll) ->-          bin lr_pair (bin l_pair ll lrl) (bin p lrr r)-        _ -> bin l_pair ll (bin p lr r)--    _ -> bin p l r-{-# INLINE balanceL #-}---- `balanceR p l r` returns a balanced tree for the sequence @l ++ [p] ++ r@.------ It assumes that @l@ and @r@ are close to being balanced, and that only--- @r@ may contain too many elements.-balanceR :: (IsBinTree c e) => e -> c -> c -> c-balanceR p l r = do-  case asBin r of-    BinTree r_pair rl rr | size r > max 1 (delta*size l) ->-      case asBin rl of-        BinTree rl_pair rll rlr | size rl >= max 2 (ratio*size rr) ->-          (bin rl_pair $! bin p l rll) $! bin r_pair rlr rr-        _ -> bin r_pair (bin p l rl) rr-    _ -> bin p l r-{-# INLINE balanceR #-}---- | Insert a new maximal element.-insertMax :: IsBinTree c e => e -> c -> c-insertMax p t =-  case asBin t of-    TipTree -> bin p tip tip-    BinTree q l r -> balanceR q l (insertMax p r)---- | Insert a new minimal element.-insertMin :: IsBinTree c e => e -> c -> c-insertMin p t =-  case asBin t of-    TipTree -> bin p tip tip-    BinTree q l r -> balanceL q (insertMin p l) r---- | link is called to insert a key and value between two disjoint subtrees.-link :: IsBinTree c e => e -> c -> c -> c-link p l r =-  case (asBin l, asBin r) of-    (TipTree, _) -> insertMin p r-    (_, TipTree) -> insertMax p l-    (BinTree py ly ry, BinTree pz lz rz)-     | delta*size l < size r -> balanceL pz (link p l lz) rz-     | delta*size r < size l -> balanceR py ly (link p ry r)-     | otherwise             -> bin p l r-{-# INLINE link #-}---- | A Strict pair-data PairS f s = PairS !f !s--deleteFindMin :: IsBinTree c e => e -> c -> c -> PairS e c-deleteFindMin p l r =-  case asBin l of-    TipTree -> PairS p r-    BinTree lp ll lr ->-      case deleteFindMin lp ll lr of-        PairS q l' -> PairS q (balanceR p l' r)-{-# INLINABLE deleteFindMin #-}--deleteFindMax :: IsBinTree c e => e -> c -> c -> PairS e c-deleteFindMax p l r =-  case asBin r of-    TipTree -> PairS p l-    BinTree rp rl rr ->-      case deleteFindMax rp rl rr of-        PairS q r' -> PairS q (balanceL p l r')-{-# INLINABLE deleteFindMax #-}---- | Concatenate two trees that are ordered with respect to each other.-merge :: IsBinTree c e => c -> c -> c-merge l r =-  case (asBin l, asBin r) of-    (TipTree, _) -> r-    (_, TipTree) -> l-    (BinTree x lx rx, BinTree y ly ry)-      | delta*size l < size r -> balanceL y (merge l ly) ry-      | delta*size r < size l -> balanceR x lx (merge rx r)-      | size l > size r ->-        case deleteFindMax x lx rx of-          PairS q l' -> balanceR q l' r-      | otherwise ->-        case deleteFindMin y ly ry of-          PairS q r' -> balanceL q l r'-{-# INLINABLE merge #-}----------------------------------------------------------------------------- Ordered operations---- | @insert p m@ inserts the binding into @m@.  It returns--- an Unchanged value if the map stays the same size and an updated--- value if a new entry was inserted.-insert :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> Updated c-insert comp x t =-  case asBin t of-    TipTree -> Updated (bin x tip tip)-    BinTree y l r ->-      case comp x y of-        LT ->-          case insert comp x l of-            Updated l'   -> Updated   (balanceL y l' r)-            Unchanged l' -> Unchanged (bin       y l' r)-        GT ->-          case insert comp x r of-            Updated r'   -> Updated   (balanceR y l r')-            Unchanged r' -> Unchanged (bin       y l r')-        EQ -> Unchanged (bin x l r)-{-# INLINABLE insert #-}---- | 'glue l r' concatenates @l@ and @r@.------ It assumes that @l@ and @r@ are already balanced with respect to each other.-glue :: IsBinTree c e => c -> c -> c-glue l r =-  case (asBin l, asBin r) of-    (TipTree, _) -> r-    (_, TipTree) -> l-    (BinTree x lx rx, BinTree y ly ry)-     | size l > size r ->-       case deleteFindMax x lx rx of-         PairS q l' -> balanceR q l' r-     | otherwise ->-       case deleteFindMin y ly ry of-         PairS q r' -> balanceL q l r'-{-# INLINABLE glue #-}--delete :: IsBinTree c e-       => (e -> Ordering)-          -- ^ Predicate that returns whether the entry is less than, greater than, or equal-          -- to the key we are entry that we are looking for.-       -> c-       -> MaybeS c-delete k t =-  case asBin t of-    TipTree -> NothingS-    BinTree p l r ->-      case k p of-        LT -> (\l' -> balanceR p l' r) <$> delete k l-        GT -> (\r' -> balanceL p l r') <$> delete k r-        EQ -> JustS (glue l r)-{-# INLINABLE delete #-}----------------------------------------------------------------------------- filter---- | Returns only entries that are less than predicate with respect to the ordering--- and Nothing if no elements are discared.-filterGt :: IsBinTree c e => (e -> Ordering) -> c -> MaybeS c-filterGt k t =-  case asBin t of-    TipTree -> NothingS-    BinTree x l r ->-      case k x of-        LT -> (\l' -> link x l' r) <$> filterGt k l-        GT -> filterGt k r <|> JustS r-        EQ -> JustS r-{-# INLINABLE filterGt #-}----- | @filterLt' k m@ returns submap of @m@ that only contains entries--- that are smaller than @k@.  If no entries are deleted then return Nothing.-filterLt :: IsBinTree c e => (e -> Ordering) -> c -> MaybeS c-filterLt k t =-  case asBin t of-    TipTree -> NothingS-    BinTree x l r ->-      case k x of-        LT -> filterLt k l <|> JustS l-        GT -> (\r' -> link x l r') <$> filterLt k r-        EQ -> JustS l-{-# INLINABLE filterLt #-}----------------------------------------------------------------------------- Union---- Insert a new key and value in the map if it is not already present.--- Used by `union`.-insertR :: forall c e . (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> c-insertR comp e m = fromMaybeS m (go e m)-  where-    go :: e -> c -> MaybeS c-    go x t =-      case asBin t of-        TipTree -> JustS (bin x tip tip)-        BinTree y l r ->-          case comp x y of-            LT -> (\l' -> balanceL y l' r) <$> go x l-            GT -> (\r' -> balanceR y l r') <$> go x r-            EQ -> NothingS-{-# INLINABLE insertR #-}---- | Union two sets-union :: (IsBinTree c e) => (e -> e -> Ordering) -> c -> c -> c-union comp t1 t2 =-  case (asBin t1, asBin t2) of-    (TipTree, _) -> t2-    (_, TipTree) -> t1-    (_, BinTree p (asBin -> TipTree) (asBin -> TipTree)) -> insertR comp p t1-    (BinTree x l r, _) ->-      link x-           (hedgeUnion_UB comp x   l t2)-           (hedgeUnion_LB comp x r   t2)-{-# INLINABLE union #-}---- | Hedge union where we only add elements in second map if key is--- strictly above a lower bound.-hedgeUnion_LB :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> c -> c-hedgeUnion_LB comp lo t1 t2 =-  case (asBin t1, asBin t2) of-    (_, TipTree) -> t1-    (TipTree, _) -> fromMaybeS t2 (filterGt (comp lo) t2)-    -- Prune left tree.-    (_, BinTree k _ r) | comp k lo <= EQ -> hedgeUnion_LB comp lo t1 r-    -- Special case when t2 is a single element.-    (_, BinTree x (asBin -> TipTree) (asBin -> TipTree)) -> insertR comp x t1-    -- Split on left-and-right subtrees of t1.-    (BinTree x l r, _) ->-      link x-           (hedgeUnion_LB_UB comp lo x  l t2)-           (hedgeUnion_LB    comp x     r t2)-{-# INLINABLE hedgeUnion_LB #-}---- | Hedge union where we only add elements in second map if key is--- strictly below a upper bound.-hedgeUnion_UB :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> c -> c -> c-hedgeUnion_UB comp hi t1 t2 =-  case (asBin t1, asBin t2) of-    (_, TipTree) -> t1-    (TipTree, _) -> fromMaybeS t2 (filterLt (comp hi) t2)-    -- Prune right tree.-    (_, BinTree x l _) | comp x hi >= EQ -> hedgeUnion_UB comp hi t1 l-    -- Special case when t2 is a single element.-    (_, BinTree x (asBin -> TipTree) (asBin -> TipTree))  -> insertR comp x t1-    -- Split on left-and-right subtrees of t1.-    (BinTree x l r, _) ->-      link x-           (hedgeUnion_UB    comp x      l t2)-           (hedgeUnion_LB_UB comp x  hi  r t2)-{-# INLINABLE hedgeUnion_UB #-}---- | Hedge union where we only add elements in second map if key is--- strictly between a lower and upper bound.-hedgeUnion_LB_UB :: (IsBinTree c e) => (e -> e -> Ordering) -> e -> e -> c -> c -> c-hedgeUnion_LB_UB comp lo hi t1 t2 =-  case (asBin t1, asBin t2) of-    (_, TipTree) -> t1-    -- Prune left tree.-    (_,   BinTree k _ r) | comp k lo <= EQ -> hedgeUnion_LB_UB comp lo hi t1 r-    -- Prune right tree.-    (_,   BinTree k l _) | comp k hi >= EQ -> hedgeUnion_LB_UB comp lo hi t1 l-    -- When t1 becomes empty (assumes lo <= k <= hi)-    (TipTree, BinTree x l r) ->-      case (filterGt (comp lo) l, filterLt (comp hi) r) of-        -- No variables in t2 were eliminated.-        (NothingS, NothingS) -> t2-        -- Relink t2 with filtered elements removed.-        (l',r') -> link x (fromMaybeS l l') (fromMaybeS r r')-    -- Special case when t2 is a single element.-    (_, BinTree x (asBin -> TipTree) (asBin -> TipTree)) -> insertR comp x t1-    -- Split on left-and-right subtrees of t1.-    (BinTree x l r, _) ->-      link x-           (hedgeUnion_LB_UB comp lo x  l t2)-           (hedgeUnion_LB_UB comp x  hi r t2)-{-# INLINABLE hedgeUnion_LB_UB #-}
− submodules/parameterized-utils/src/Data/Parameterized/Utils/Endian.hs 
@@ -1,3 +0,0 @@-module Data.Parameterized.Utils.Endian where--data Endian = LittleEndian | BigEndian deriving (Eq,Show,Ord)
− submodules/parameterized-utils/src/Data/Parameterized/Vector.hs 
@@ -1,507 +0,0 @@-{-# Language GADTs, DataKinds, TypeOperators, BangPatterns #-}-{-# Language PatternGuards #-}-{-# Language TypeApplications, ScopedTypeVariables #-}-{-# Language Rank2Types, RoleAnnotations #-}-{-# Language CPP #-}-#if __GLASGOW_HASKELL__ >= 805-{-# Language NoStarIsType #-}-#endif--- | A vector fixed-size vector of typed elements.-module Data.Parameterized.Vector-  ( Vector-    -- * Lists-  , fromList-  , toList--    -- * Length-  , length-  , nonEmpty-  , lengthInt--  -- * Indexing-  , elemAt-  , elemAtMaybe-  , elemAtUnsafe--  -- * Update-  , insertAt-  , insertAtMaybe--    -- * Sub sequences-  , uncons-  , slice-  , Data.Parameterized.Vector.take--    -- * Zipping-  , zipWith-  , zipWithM-  , zipWithM_-  , interleave--    -- * Reorder-  , shuffle-  , reverse-  , rotateL-  , rotateR-  , shiftL-  , shiftR--    -- * Construction-  , singleton-  , cons-  , snoc-  , generate-  , generateM--    -- * Splitting and joining-    -- ** General-  , joinWithM-  , joinWith-  , splitWith-  , splitWithA--    -- ** Vectors-  , split-  , join-  , append--  ) where--import qualified Data.Vector as Vector-import Data.Functor.Compose-import Data.Coerce-import Data.Vector.Mutable (MVector)-import qualified Data.Vector.Mutable as MVector-import Control.Monad.ST-import Data.Functor.Identity-import Data.Parameterized.NatRepr-import Data.Proxy-import Prelude hiding (length,reverse,zipWith)-import Numeric.Natural--import Data.Parameterized.Utils.Endian---- | Fixed-size non-empty vectors.-data Vector n a where-  Vector :: (1 <= n) => !(Vector.Vector a) -> Vector n a--type role Vector nominal representational--instance Eq a => Eq (Vector n a) where-  (Vector x) == (Vector y) = x == y--instance Show a => Show (Vector n a) where-  show (Vector x) = show x---- | Get the elements of the vector as a list, lowest index first.-toList :: Vector n a -> [a]-toList (Vector v) = Vector.toList v-{-# Inline toList #-}---- | Length of the vector.--- @O(1)@-length :: Vector n a -> NatRepr n-length (Vector xs) =-  activateNatReprCoercionBackdoor_IPromiseIKnowWhatIAmDoing $ \mk ->-    mk (fromIntegral (Vector.length xs) :: Natural)-{-# INLINE length #-}---- | The length of the vector as an "Int".-lengthInt :: Vector n a -> Int-lengthInt (Vector xs) = Vector.length xs-{-# Inline lengthInt #-}--elemAt :: ((i+1) <= n) => NatRepr i -> Vector n a -> a-elemAt n (Vector xs) = xs Vector.! widthVal n---- | Get the element at the given index.--- @O(1)@-elemAtMaybe :: Int -> Vector n a -> Maybe a-elemAtMaybe n (Vector xs) = xs Vector.!? n-{-# INLINE elemAt #-}---- | Get the element at the given index.--- Raises an exception if the element is not in the vector's domain.--- @O(1)@-elemAtUnsafe :: Int -> Vector n a -> a-elemAtUnsafe n (Vector xs) = xs Vector.! n-{-# INLINE elemAtUnsafe #-}----- | Insert an element at the given index.--- @O(n)@.-insertAt :: ((i + 1) <= n) => NatRepr i -> a -> Vector n a -> Vector n a-insertAt n a (Vector xs) = Vector (Vector.unsafeUpd xs [(widthVal n,a)])---- | Insert an element at the given index.--- Return 'Nothing' if the element is outside the vector bounds.--- @O(n)@.-insertAtMaybe :: Int -> a -> Vector n a -> Maybe (Vector n a)-insertAtMaybe n a (Vector xs)-  | 0 <= n && n < Vector.length xs = Just (Vector (Vector.unsafeUpd xs [(n,a)]))-  | otherwise = Nothing----- | Proof that the length of this vector is not 0.-nonEmpty :: Vector n a -> LeqProof 1 n-nonEmpty (Vector _) = LeqProof-{-# Inline nonEmpty #-}----- | Remove the first element of the vector, and return the rest, if any.-uncons :: forall n a.  Vector n a -> (a, Either (n :~: 1) (Vector (n-1) a))-uncons v@(Vector xs) = (Vector.head xs, mbTail)-  where-  mbTail :: Either (n :~: 1) (Vector (n - 1) a)-  mbTail = case testStrictLeq (knownNat @1) (length v) of-             Left n2_leq_n ->-               do LeqProof <- return (leqSub2 n2_leq_n (leqRefl (knownNat @1)))-                  return (Vector (Vector.tail xs))-             Right Refl    -> Left Refl-{-# Inline uncons #-}--------------------------------------------------------------------------------------- | Make a vector of the given length and element type.--- Returns "Nothing" if the input list does not have the right number of--- elements.--- @O(n)@.-fromList :: (1 <= n) => NatRepr n -> [a] -> Maybe (Vector n a)-fromList n xs-  | widthVal n == Vector.length v = Just (Vector v)-  | otherwise                     = Nothing-  where-  v = Vector.fromList xs-{-# INLINE fromList #-}----- | Extract a subvector of the given vector.-slice :: (i + w <= n, 1 <= w) =>-            NatRepr i {- ^ Start index -} ->-            NatRepr w {- ^ Width of sub-vector -} ->-            Vector n a -> Vector w a-slice i w (Vector xs) = Vector (Vector.slice (widthVal i) (widthVal w) xs)-{-# INLINE slice #-}---- | Take the front (lower-indexes) part of the vector.-take :: forall n x a. (1 <= n) => NatRepr n -> Vector (n + x) a -> Vector n a-take | LeqProof <- prf = slice (knownNat @0)-  where-  prf = leqAdd (leqRefl (Proxy @n)) (Proxy @x)------------------------------------------------------------------------------------instance Functor (Vector n) where-  fmap f (Vector xs) = Vector (Vector.map f xs)-  {-# Inline fmap #-}--instance Foldable (Vector n) where-  foldMap f (Vector xs) = foldMap f xs--instance Traversable (Vector n) where-  traverse f (Vector xs) = Vector <$> traverse f xs-  {-# Inline traverse #-}---- | Zip two vectors, potentially changing types.--- @O(n)@-zipWith :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c-zipWith f (Vector xs) (Vector ys) = Vector (Vector.zipWith f xs ys)-{-# Inline zipWith #-}--zipWithM :: Monad m => (a -> b -> m c) ->-                       Vector n a -> Vector n b -> m (Vector n c)-zipWithM f (Vector xs) (Vector ys) = Vector <$> Vector.zipWithM f xs ys-{-# Inline zipWithM #-}--zipWithM_ :: Monad m => (a -> b -> m ()) -> Vector n a -> Vector n b -> m ()-zipWithM_ f (Vector xs) (Vector ys) = Vector.zipWithM_ f xs ys-{-# Inline zipWithM_ #-}--{- | Interleave two vectors.  The elements of the first vector are-at even indexes in the result, the elements of the second are at odd indexes. -}-interleave ::-  forall n a. (1 <= n) => Vector n a -> Vector n a -> Vector (2 * n) a-interleave (Vector xs) (Vector ys)-  | LeqProof <- leqMulPos (Proxy @2) (Proxy @n) = Vector zs-  where-  len = Vector.length xs + Vector.length ys-  zs  = Vector.generate len (\i -> let v = if even i then xs else ys-                                   in v Vector.! (i `div` 2))-------------------------------------------------------------------------------------{- | Move the elements around, as specified by the given function.-  * Note: the reindexing function says where each of the elements-          in the new vector come from.-  * Note: it is OK for the same input element to end up in mulitple places-          in the result.-@O(n)@--}-shuffle :: (Int -> Int) -> Vector n a -> Vector n a-shuffle f (Vector xs) = Vector ys-  where-  ys = Vector.generate (Vector.length xs) (\i -> xs Vector.! f i)-{-# Inline shuffle #-}---- | Reverse the vector.-reverse :: forall a n. (1 <= n) => Vector n a -> Vector n a-reverse x = shuffle (\i -> lengthInt x - i - 1) x---- | Rotate "left".  The first element of the vector is on the "left", so--- rotate left moves all elemnts toward the corresponding smaller index.--- Elements that fall off the beginning end up at the end.-rotateL :: Int -> Vector n a -> Vector n a-rotateL !n xs = shuffle rotL xs-  where-  !len   = lengthInt xs-  rotL i = (i + n) `mod` len          -- `len` is known to be >= 1-{-# Inline rotateL #-}---- | Rotate "right".  The first element of the vector is on the "left", so--- rotate right moves all elemnts toward the corresponding larger index.--- Elements that fall off the end, end up at the beginning.-rotateR :: Int -> Vector n a -> Vector n a-rotateR !n xs = shuffle rotR xs-  where-  !len   = lengthInt xs-  rotR i = (i - n) `mod` len        -- `len` is known to be >= 1-{-# Inline rotateR #-}--{- | Move all elements towards smaller indexes.-Elements that fall off the front are ignored.-Empty slots are filled in with the given element.-@O(n)@. -}-shiftL :: Int -> a -> Vector n a -> Vector n a-shiftL !x a (Vector xs) = Vector ys-  where-  !len = Vector.length xs-  ys   = Vector.generate len (\i -> let j = i + x-                                    in if j >= len then a else xs Vector.! j)-{-# Inline shiftL #-}--{- | Move all elements towards the larger indexes.-Elements that "fall" off the end are ignored.-Empty slots are filled in with the given element.-@O(n)@. -}-shiftR :: Int -> a -> Vector n a -> Vector n a-shiftR !x a (Vector xs) = Vector ys-  where-  !len = Vector.length xs-  ys   = Vector.generate len (\i -> let j = i - x-                                    in if j < 0 then a else xs Vector.! j)-{-# Inline shiftR #-}---------------------------------------------------------------------------------i---- | Append two vectors. The first one is at lower indexes in the result.-append :: Vector m a -> Vector n a -> Vector (m + n) a-append v1@(Vector xs) v2@(Vector ys) =-  case leqAddPos (length v1) (length v2) of { LeqProof ->-    Vector (xs Vector.++ ys)-  }-{-# Inline append #-}------------------------------------------------------------------------------------- Constructing Vectors---- | Vector with exactly one element-singleton :: forall a. a -> Vector 1 a-singleton a = Vector (Vector.singleton a)--leqLen :: forall n a. Vector n a -> LeqProof 1 (n + 1)-leqLen v =-  let leqSucc :: forall f z. f z -> LeqProof z (z + 1)-      leqSucc fz = leqAdd (leqRefl fz :: LeqProof z z) (knownNat @1)-  in leqTrans (nonEmpty v :: LeqProof 1 n) (leqSucc (length v))---- | Add an element to the head of a vector-cons :: forall n a. a -> Vector n a -> Vector (n+1) a-cons a v@(Vector x) = case leqLen v of LeqProof -> (Vector (Vector.cons a x))---- | Add an element to the tail of a vector-snoc :: forall n a. Vector n a -> a -> Vector (n+1) a-snoc v@(Vector x) a = case leqLen v of LeqProof -> (Vector (Vector.snoc x a))---- | This newtype wraps Vector so that we can curry it in the call to--- @natRecBounded@. It adds 1 to the length so that the base case is--- a @Vector@ of non-zero length.-newtype Vector' a n = MkVector' (Vector (n+1) a)--unVector' :: Vector' a n -> Vector (n+1) a-unVector' (MkVector' v) = v--snoc' :: forall a m. Vector' a m -> a -> Vector' a (m+1)-snoc' v = MkVector' . snoc (unVector' v)--generate' :: forall h a-           . NatRepr h-          -> (forall n. (n <= h) => NatRepr n -> a)-          -> Vector' a h-generate' h gen =-  case isZeroOrGT1 h of-    Left Refl -> base-    Right LeqProof ->-      case (minusPlusCancel h (knownNat @1) :: h - 1 + 1 :~: h) of { Refl ->-      natRecBounded (decNat h) (decNat h) base step-      }-  where base :: Vector' a 0-        base = MkVector' $ singleton (gen (knownNat @0))-        step :: forall m. (1 <= h, m <= h - 1)-             => NatRepr m -> Vector' a m -> Vector' a (m + 1)-        step m v =-          case minusPlusCancel h (knownNat @1) :: h - 1 + 1 :~: h of { Refl ->-          case (leqAdd2 (LeqProof :: LeqProof m (h-1))-                        (LeqProof :: LeqProof 1 1) :: LeqProof (m+1) h) of { LeqProof ->-            snoc' v (gen (incNat m))-          }}---- | Apply a function to each element in a range starting at zero;--- return the a vector of values obtained.--- cf. both @natFromZero@ and @Data.Vector.generate@-generate :: forall h a-          . NatRepr h-         -> (forall n. (n <= h) => NatRepr n -> a)-         -> Vector (h + 1) a-generate h gen = unVector' (generate' h gen)---- | Since @Vector@ is traversable, we can pretty trivially sequence--- @natFromZeroVec@ inside a monad.-generateM :: forall m h a. (Monad m)-          => NatRepr h-          -> (forall n. (n <= h) => NatRepr n -> m a)-          -> m (Vector (h + 1) a)-generateM h gen = sequence $ generate h gen------------------------------------------------------------------------------------coerceVec :: Coercible a b => Vector n a -> Vector n b-coerceVec = coerce---- | Monadically join a vector of values, using the given function.--- This functionality can sometimes be reproduced by creating a newtype--- wrapper and using @joinWith@, this implementation is provided for--- convenience.-joinWithM ::-  forall m f n w.-  (1 <= w, Monad m) =>-  (forall l. (1 <= l) => NatRepr l -> f w -> f l -> m (f (w + l)))-  {- ^ A function for appending contained elements.-       Earlier vector indexes are the first argument of the join function.-       Pass a different function to implmenet little/big endian behaviors -} ->-  NatRepr w -> Vector n (f w) -> m (f (n * w))--joinWithM jn w = fmap fst . go-  where-  go :: forall l. Vector l (f w) -> m (f (l * w), NatRepr (l * w))-  go exprs =-    case uncons exprs of-      (a, Left Refl) -> return (a, w)-      (a, Right rest) ->-        case nonEmpty rest                of { LeqProof ->-        case leqMulPos (length rest) w    of { LeqProof ->-        case nonEmpty exprs               of { LeqProof ->-        case lemmaMul w (length exprs)    of { Refl -> do-          -- @siddharthist: This could probably be written applicatively?-          (res, sz) <- go rest-          joined <- jn sz a res-          return (joined, addNat w sz)-        }}}}---- | Join a vector of values, using the given function.-joinWith ::-  forall f n w.-  (1 <= w) =>-  (forall l. (1 <= l) => NatRepr l -> f w -> f l -> f (w + l))-  {- ^ A function for appending contained elements.-       Earlier vector indexes are the first argument of the join function.-       Pass a different function to implmenet little/big endian behaviors -} ->-  NatRepr w -> Vector n (f w) -> f (n * w)-joinWith jn w v = runIdentity $ joinWithM (\n x -> pure . (jn n x)) w v-{-# Inline joinWith #-}---- | Split a bit-vector into a vector of bit-vectors.--- If "LittleEndian", then less significant bits go into smaller indexes.--- If "BigEndian", then less significant bits go into larger indexes.-splitWith :: forall f w n.-  (1 <= w, 1 <= n) =>-  Endian ->-  (forall i. (i + w <= n * w) =>-             NatRepr (n * w) -> NatRepr i -> f (n * w) -> f w)-  {- ^ A function for slicing out a chunk of length @w@, starting at @i@ -} ->-  NatRepr n -> NatRepr w -> f (n * w) -> Vector n (f w)-splitWith endian select n w val = Vector (Vector.create initializer)-  where-  len          = widthVal n-  start :: Int-  next :: Int -> Int-  (start,next) = case endian of-                   LittleEndian -> (0, succ)-                   BigEndian    -> (len - 1, pred)--  initializer :: forall s. ST s (MVector s (f w))-  initializer =-    do LeqProof <- return (leqMulPos n w)-       LeqProof <- return (leqMulMono n w)--       v <- MVector.new len-       let fill :: Int -> NatRepr i -> ST s ()-           fill loc i =-             let end = addNat i w in-             case testLeq end inLen of-               Just LeqProof ->-                 do MVector.write v loc (select inLen i val)-                    fill (next loc) end-               Nothing -> return ()---       fill start (knownNat @0)-       return v--  inLen :: NatRepr (n * w)-  inLen = natMultiply n w-{-# Inline splitWith #-}---- We can sneakily put our functor in the parameter "f" of @splitWith@ using the--- @Compose@ newtype.--- | An applicative version of @splitWith@.-splitWithA :: forall f g w n. (Applicative f, 1 <= w, 1 <= n) =>-  Endian ->-  (forall i. (i + w <= n * w) =>-             NatRepr (n * w) -> NatRepr i -> g (n * w) -> f (g w))-  {- ^ f function for slicing out f chunk of length @w@, starting at @i@ -} ->-  NatRepr n -> NatRepr w -> g (n * w) -> f (Vector n (g w))-splitWithA e select n w val = traverse getCompose $-  splitWith @(Compose f g) e select' n w $ Compose (pure val)-  where -- Wrap everything in Compose-        select' :: (forall i. (i + w <= n * w)-                => NatRepr (n * w) -> NatRepr i -> Compose f g (n * w) -> Compose f g w)-        -- Whatever we pass in as "val" is what's passed to select anyway,-        -- so there's no need to examine the argument. Just use "val" directly here.-        select' nw i _ = Compose $ select nw i val--newtype Vec a n = Vec (Vector n a)--vSlice :: (i + w <= l, 1 <= w) =>-  NatRepr w -> NatRepr l -> NatRepr i -> Vec a l -> Vec a w-vSlice w _ i (Vec xs) = Vec (slice i w xs)-{-# Inline vSlice #-}---- | Append the two bit vectors.  The first argument is--- at the lower indexes of the resulting vector.-vAppend :: NatRepr n -> Vec a m -> Vec a n -> Vec a (m + n)-vAppend _ (Vec xs) (Vec ys) = Vec (append xs ys)-{-# Inline vAppend #-}---- | Split a vector into a vector of vectors.-split :: (1 <= w, 1 <= n) =>-        NatRepr n -> NatRepr w -> Vector (n * w) a -> Vector n (Vector w a)-split n w xs = coerceVec (splitWith LittleEndian (vSlice w) n w (Vec xs))-{-# Inline split #-}---- | Join a vector of vectors into a single vector.-join :: (1 <= w) => NatRepr w -> Vector n (Vector w a) -> Vector (n * w) a-join w xs = ys-  where Vec ys = joinWith vAppend w (coerceVec xs)-{-# Inline join #-}
− submodules/parameterized-utils/test/Test/Context.hs 
@@ -1,178 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-module Test.Context-( contextTests-) where--import Test.Tasty-import Test.QuickCheck-import Test.Tasty.QuickCheck--import Control.Lens-import Data.Parameterized.Classes-import Data.Parameterized.TraversableFC-import Data.Parameterized.Some--import qualified Data.Parameterized.Context as C-import qualified Data.Parameterized.Context.Safe as S-import qualified Data.Parameterized.Context.Unsafe as U--data Payload (ty :: *) where-  IntPayload    :: Int -> Payload Int-  StringPayload :: String -> Payload String-  BoolPayload   :: Bool -> Payload Bool--instance TestEquality Payload where-  testEquality (IntPayload x) (IntPayload y) = if x == y then Just Refl else Nothing-  testEquality (StringPayload x) (StringPayload y) = if x == y then Just Refl else Nothing-  testEquality (BoolPayload x) (BoolPayload y) = if x == y then Just Refl else Nothing-  testEquality _ _ = Nothing--instance Show (Payload tp) where-  show (IntPayload x) = show x-  show (StringPayload x) = show x-  show (BoolPayload x) = show x--instance ShowF Payload--instance Arbitrary (Some Payload) where-  arbitrary = oneof-    [ Some . IntPayload <$> arbitrary-    , Some . StringPayload <$> arbitrary-    , Some . BoolPayload <$> arbitrary-    ]--type UAsgn = U.Assignment Payload-type SAsgn = S.Assignment Payload--mkUAsgn :: [Some Payload] -> Some UAsgn-mkUAsgn = go U.empty- where go :: UAsgn ctx -> [Some Payload] -> Some UAsgn-       go a [] = Some a-       go a (Some x : xs) = go (U.extend a x) xs--mkSAsgn :: [Some Payload] -> Some SAsgn-mkSAsgn = go S.empty- where go :: SAsgn ctx -> [Some Payload] -> Some SAsgn-       go a [] = Some a-       go a (Some x : xs) = go (S.extend a x) xs--instance Arbitrary (Some UAsgn) where-  arbitrary = mkUAsgn <$> arbitrary-instance Arbitrary (Some SAsgn) where-  arbitrary = mkSAsgn <$> arbitrary--twiddle :: Payload a -> Payload a-twiddle (IntPayload n) = IntPayload (n+1)-twiddle (StringPayload str) = StringPayload (str++"asdf")-twiddle (BoolPayload b) = BoolPayload (not b)--contextTests :: IO TestTree-contextTests = testGroup "Context" <$> return-   [ testProperty "safe_index_eq" $ \v vs i -> ioProperty $ do-         let vals = v:vs-         let i' = min (max 0 i) (length vals - 1)-         Some a <- return $ mkSAsgn vals-         Just (Some idx) <- return $ S.intIndex i' (S.size a)-         return (Some (a S.! idx) == vals !! i')-   , testProperty "unsafe_index_eq" $ \v vs i -> ioProperty $ do-         let vals = v:vs-         let i' = min (max 0 i) (length vals - 1)-         Some a <- return $ mkUAsgn vals-         Just (Some idx) <- return $ U.intIndex i' (U.size a)-         return (Some (a U.! idx) == vals !! i')-   , testProperty "safe_tolist" $ \vals -> ioProperty $ do-         Some a <- return $ mkSAsgn vals-         let vals' = toListFC Some a-         return (vals == vals')-   , testProperty "unsafe_tolist" $ \vals -> ioProperty $ do-         Some a <- return $ mkUAsgn vals-         let vals' = toListFC Some a-         return (vals == vals')-   , testProperty "adjust test monadic" $ \v vs i -> ioProperty $ do-         let vals = v:vs  -- ensures vals is not an empty array-         Some x <- return $ mkUAsgn vals-         Some y <- return $ mkSAsgn vals-         let i' = min (max 0 i) (length vals - 1)--         Just (Some idx_x) <- return $ U.intIndex i' (U.size x)-         Just (Some idx_y) <- return $ S.intIndex i' (S.size y)--         x' <- U.adjustM (return . twiddle) idx_x x-         y' <- S.adjustM (return . twiddle) idx_y y--         return (toListFC Some x' == toListFC Some y')--   , testProperty "adjust test" $ \v vs i -> ioProperty $ do-         let vals = v:vs  -- ensures vals is not an empty array-         Some x <- return $ mkUAsgn vals-         Some y <- return $ mkSAsgn vals-         let i' = min (max 0 i) (length vals - 1)--         Just (Some idx_x) <- return $ U.intIndex i' (U.size x)-         Just (Some idx_y) <- return $ S.intIndex i' (S.size y)--         let x' = over (ixF idx_x) twiddle x-             y' = (ixF idx_y) %~ twiddle $ y-             x'' = U.adjust twiddle idx_x x-             y'' = S.adjust twiddle idx_y y--         return (toListFC Some x' == toListFC Some y' &&-                 -- adjust actually modified the entry-                 toListFC Some x /= toListFC Some x' &&-                 toListFC Some y /= toListFC Some y' &&-                 -- verify new version is equivalent to older deprecated version-                 toListFC Some x'' == toListFC Some x' &&-                 toListFC Some y'' == toListFC Some y')--   , testProperty "update test" $ \v vs i -> ioProperty $ do-         let vals = v:vs  -- ensures vals is not an empty array-         Some x <- return $ mkUAsgn vals-         Some y <- return $ mkSAsgn vals-         let i' = min (max 0 i) (length vals - 1)--         Just (Some idx_x) <- return $ U.intIndex i' (U.size x)-         Just (Some idx_y) <- return $ S.intIndex i' (S.size y)--         let x' = over (ixF idx_x) twiddle x-             y' = (ixF idx_y) %~ twiddle $ y-             updX = set (ixF idx_x) (x' U.! idx_x) x-             updY = (ixF idx_y) .~  (y' S.! idx_y) $ y-             updX' = U.update idx_x (x' U.! idx_x) x-             updY' = S.update idx_y (y' S.! idx_y) y--         return (toListFC Some updX == toListFC Some updY &&-                 -- update actually modified the entry-                 toListFC Some x /= toListFC Some updX &&-                 toListFC Some y /= toListFC Some updY &&-                 -- update modified the expected entry-                 toListFC Some x' == toListFC Some updX &&-                 toListFC Some y' == toListFC Some updY &&-                 -- verify new version is equivalent to older deprecated version-                 toListFC Some updX == toListFC Some updX' &&-                 toListFC Some updY == toListFC Some updY'-                )--   , testProperty "safe_eq" $ \vals1 vals2 -> ioProperty $ do-         Some x <- return $ mkSAsgn vals1-         Some y <- return $ mkSAsgn vals2-         case testEquality x y of-           Just Refl -> return $ vals1 == vals2-           Nothing   -> return $ vals1 /= vals2-   , testProperty "unsafe_eq" $ \vals1 vals2 -> ioProperty $ do-         Some x <- return $ mkUAsgn vals1-         Some y <- return $ mkUAsgn vals2-         case testEquality x y of-           Just Refl -> return $ vals1 == vals2-           Nothing   -> return $ vals1 /= vals2--   , testProperty "append_take" $ \vals1 vals2 -> ioProperty $ do-         Some x <- return $ mkUAsgn vals1-         Some y <- return $ mkUAsgn vals2-         let z = x U.<++> y-         let x' = C.take (U.size x) (U.size y) z-         return $ isJust $ testEquality x x'-   ]
− submodules/parameterized-utils/test/Test/NatRepr.hs 
@@ -1,18 +0,0 @@-module Test.NatRepr-( natTests-) where--import Test.Tasty-import Test.Tasty.QuickCheck--import Data.Parameterized.NatRepr-import Data.Parameterized.Some-import GHC.TypeLits--natTests :: IO TestTree-natTests = testGroup "Nat" <$> return-  [ testProperty "withKnownNat" $ \nInt ->-      case someNat nInt of-        Nothing -> nInt < 0-        Just (Some r) -> nInt == withKnownNat r (natVal r)-  ]
− submodules/parameterized-utils/test/Test/Vector.hs 
@@ -1,67 +0,0 @@-{-# Language DataKinds #-}-{-# Language ExplicitForAll #-}-{-# Language TypeOperators #-}-{-# Language TypeFamilies #-}-{-# Language FlexibleInstances #-}-{-# Language ScopedTypeVariables #-}-{-# Language StandaloneDeriving #-}-{-# Language CPP #-}-#if __GLASGOW_HASKELL__ >= 805-{-# Language NoStarIsType #-}-#endif-module Test.Vector-( vecTests-) where--import Test.Tasty-import Test.Tasty.QuickCheck (Arbitrary(..), Gen, testProperty)--import Data.Parameterized.NatRepr-import Data.Parameterized.Vector-import GHC.TypeLits-import Prelude hiding (reverse)--instance KnownNat n => Arbitrary (NatRepr n) where-  arbitrary = return knownNat---- GHC thinks that this instances overlaps with the--- "Arbitrary a => Arbitrary (Maybe a)" instance from QuickCheck, but it doesn't:--- there is no "Arbitrary a => Arbitrary (Vector n a)".------ While it might seem like this would just successfully generate a lot--- of "Nothing", it does a pretty good job. Just try changing one of the tests!-instance {-# OVERLAPS #-} forall a n. (1 <= n, Arbitrary a, KnownNat n)-    => Arbitrary (Maybe (Vector n a)) where-  arbitrary = do-    n <- (arbitrary :: Gen (NatRepr n))-    l <- (arbitrary :: Gen [a])-    return $ fromList n l--instance Show (Int -> Ordering) where-  show _ = "unshowable"---- We use @Ordering@ just because it's simple-vecTests :: IO TestTree-vecTests = testGroup "Vector" <$> return-  [ testProperty "reverse100" $-      \n v -> fromList (n :: NatRepr 100) (v :: [Ordering]) ==-              (reverse <$> (reverse <$> (fromList n v)))-  , testProperty "reverseSingleton" $-      \n v -> fromList (n :: NatRepr 1) (v :: [Ordering]) ==-              (reverse <$> (fromList n v))-  , testProperty "split-join" $-      \n w v -> (v :: Maybe (Vector (5 * 5) Ordering)) ==-                (join (n :: NatRepr 5) . split n (w :: NatRepr 5) <$> v)-  -- @cons@ is the same for vectors or lists-  , testProperty "cons" $-      \n v x -> (cons x <$> fromList (n :: NatRepr 20) (v :: [Ordering])) ==-                (fromList (incNat n) (x:v))-  -- @snoc@ is like appending to a list-  , testProperty "snoc" $-      \n v x -> (flip snoc x <$> fromList (n :: NatRepr 20) (v :: [Ordering])) ==-                (fromList (incNat n) (v ++ [x]))-  -- @generate@ is like mapping a function over indices-  , testProperty "generate" $-      \n f -> Just (generate (n :: NatRepr 55) ((f :: Int -> Ordering) . widthVal)) ==-              (fromList (incNat n) (map f [0..widthVal n]) :: Maybe (Vector 56 Ordering))-  ]
− submodules/parameterized-utils/test/UnitTest.hs 
@@ -1,24 +0,0 @@-import Test.Tasty-import Test.Tasty.Ingredients-import Test.Tasty.Runners.AntXML--import qualified Test.Context-import qualified Test.NatRepr-import qualified Test.Vector--main :: IO ()-main = tests >>= defaultMainWithIngredients ingrs--ingrs :: [Ingredient]-ingrs =-   [ antXMLRunner-   ]-   ++-   defaultIngredients--tests :: IO TestTree-tests = testGroup "ParameterizedUtils" <$> sequence-  [ Test.Context.contextTests-  , Test.NatRepr.natTests-  , Test.Vector.vecTests-  ]