{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Cryptol-to-Hyle translation: the engine behind rwc's Cryptol
--   foreign-function interface. 'translate' loads and typechecks a
--   Cryptol module (with the Cryptol implementation itself -- the
--   typechecker needs z3 on the PATH), elaborates the instantiation
--   @fn : ty@ (so Cryptol's own typechecker decides whether the use-site
--   type is admissible), monomorphizes it with Cryptol's specializer,
--   and translates the resulting closure of monomorphic definitions to
--   Hyle.
--
--   The translation is the inverse of the width-preserving embedding the
--   Cryptol backend uses (doc/hyle.md, section 8.4): a Cryptol word
--   @[n]@ is a Hyle bitvector of the same numeric value, sequence and
--   tuple element zero sits at the most-significant end, and @Bit@ is
--   one bit. Cryptol's specializer erases the type arguments of
--   primitive instances (a literal's value, an index operator's
--   dimensions), so specialization runs through its lower-level
--   @S.withDeclGroups@ interface, whose name map recovers each
--   primitive clone's instantiation types.
--
--   Supported fragment: combinational functions over Bit, words,
--   vectors, tuples, records, newtypes, enums (case expressions), and
--   @Z n@ (modular arithmetic). if-then-else; local value and function
--   bindings; higher-order functions applied to statically known
--   functions; comprehensions, folds, and scans (unrolled); recursive
--   finite comprehensions (the message-schedule\/key-schedule\/CBC idiom,
--   unrolled element-wise); type-indexed recursion (unrolled per
--   instantiation); infinite streams under statically bounded demand
--   (a finite take or a constant index; see 'infPrefix'); the scalar,
--   slicing, sequence, indexing, rotate, update, and polynomial
--   (pmult\/pdiv\/pmod, constant divisor)
--   primitives. Records, enums, and @Z n@ are interior-only: the entry
--   point's type must be words\/vectors\/tuples (the rwc side has no
--   counterpart). Enum values are laid out tag\#pad\#args with the tag at
--   the most-significant end and the tag width nbits(#constructors) --
--   the same convention the Eidos fold uses for ReWire ADTs.
--   error/undefined become a zero poison constant and trace the
--   identity, both with warnings. Value recursion, unbounded-demand
--   infinite streams, floating point, and Integer/Rational at runtime
--   are rejected with (it is hoped) actionable messages.
module ReWire.Cryptol.Translate (translate) where

import ReWire.Annotation (noAnn)
import ReWire.BitVector (BV (..), bitVec, zeros, nbits)
import ReWire.Pretty (showt)

import qualified ReWire.Hyle.Syntax as A

import qualified Cryptol.Eval                 as E
import qualified Cryptol.ModuleSystem         as M
import qualified Cryptol.ModuleSystem.Env     as ME
import qualified Cryptol.ModuleSystem.Monad   as MM
import qualified Cryptol.ModuleSystem.Name    as N
import qualified Cryptol.Parser               as P
import qualified Cryptol.Transform.Specialize as S
import qualified Cryptol.TypeCheck.AST        as T
import qualified Cryptol.TypeCheck.InferTypes as TI
import qualified Cryptol.TypeCheck.Solver.SMT as SMT
import qualified Cryptol.TypeCheck.Subst      as TS
import qualified Cryptol.TypeCheck.TypeMap    as TM
import qualified Cryptol.TypeCheck.TypeOf     as T (fastTypeOf)
import qualified Cryptol.Utils.Ident          as I
import qualified Cryptol.Utils.Logger         as L
import Cryptol.Utils.PP (pp)
import Cryptol.Utils.RecordMap (canonicalFields, recordElements)

import Control.Exception (try, SomeException)
import Control.Monad (unless, foldM)
import Control.Monad.Except (ExceptT (..), runExceptT, throwError, liftEither)
import Control.Monad.IO.Class (liftIO)
import Data.Bits (testBit)
import Data.Char (isAlphaNum)
import Data.Graph (stronglyConnComp, SCC (..))
import Data.HashMap.Strict (HashMap)
import Data.List (genericLength)
import Data.Maybe (isJust)
import Data.Text (Text)
import System.Environment (lookupEnv)
import System.FilePath (takeDirectory)
import Text.Read (readMaybe)

import qualified Data.ByteString     as BS
import qualified Data.HashMap.Strict as HM
import qualified Data.Map            as Map
import qualified Data.Text           as T

-- | Translate function @fn@ from Cryptol module @file@, at the
--   monomorphic Cryptol type @ty@, to a self-contained set of Hyle
--   definitions whose entry point is named @entry@ (helpers are prefixed
--   with it), plus any compile-time warnings (e.g. an @error@ compiled to
--   a poison constant). Left is a (possibly multi-line, source-located)
--   diagnostic.
translate :: FilePath -> Text -> Text -> Text -> IO (Either Text ([A.Defn], [Text]))
translate :: FilePath
-> Text -> Text -> Text -> IO (Either Text ([Defn], [Text]))
translate FilePath
file Text
fn Text
ty Text
entry = (SomeException -> Either Text ([Defn], [Text]))
-> (Either Text ([Defn], [Text]) -> Either Text ([Defn], [Text]))
-> Either SomeException (Either Text ([Defn], [Text]))
-> Either Text ([Defn], [Text])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> Either Text ([Defn], [Text])
bail Either Text ([Defn], [Text]) -> Either Text ([Defn], [Text])
forall a. a -> a
id (Either SomeException (Either Text ([Defn], [Text]))
 -> Either Text ([Defn], [Text]))
-> IO (Either SomeException (Either Text ([Defn], [Text])))
-> IO (Either Text ([Defn], [Text]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO (Either Text ([Defn], [Text]))
-> IO (Either SomeException (Either Text ([Defn], [Text])))
forall e a. Exception e => IO a -> IO (Either e a)
try IO (Either Text ([Defn], [Text]))
go :: IO (Either SomeException (Either Text ([A.Defn], [Text]))))
      where bail :: SomeException -> Either Text ([A.Defn], [Text])
            bail :: SomeException -> Either Text ([Defn], [Text])
bail SomeException
e = Text -> Either Text ([Defn], [Text])
forall a b. a -> Either a b
Left (Text -> Either Text ([Defn], [Text]))
-> Text -> Either Text ([Defn], [Text])
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n(is z3 on the PATH?)"

            go :: IO (Either Text ([A.Defn], [Text]))
            go :: IO (Either Text ([Defn], [Text]))
go = do
                  maxNodes <- Integer -> (Integer -> Integer) -> Maybe Integer -> Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
defaultMaxNodes Integer -> Integer
forall a. a -> a
id (Maybe Integer -> Integer)
-> (Maybe FilePath -> Maybe Integer) -> Maybe FilePath -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe FilePath -> (FilePath -> Maybe Integer) -> Maybe Integer
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> Maybe Integer
forall a. Read a => FilePath -> Maybe a
readMaybe) (Maybe FilePath -> Integer) -> IO (Maybe FilePath) -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"RWC_CRY_MAX_NODES"
                  env0 <- M.initialModuleEnv
                  let env = ModuleEnv
env0 { ME.meSearchPath = takeDirectory file : ME.meSearchPath env0 }
                  SMT.withSolver (pure ()) (TI.defaultSolverConfig $ ME.meSearchPath env) $ \ Solver
solver -> ExceptT Text IO ([Defn], [Text])
-> IO (Either Text ([Defn], [Text]))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO ([Defn], [Text])
 -> IO (Either Text ([Defn], [Text])))
-> ExceptT Text IO ([Defn], [Text])
-> IO (Either Text ([Defn], [Text]))
forall a b. (a -> b) -> a -> b
$ do
                        let minp :: ModuleEnv -> ModuleInput IO
minp ModuleEnv
menv = M.ModuleInput
                                    { minpCallStacks :: Bool
M.minpCallStacks  = Bool
False
                                    , minpSaveRenamed :: Bool
M.minpSaveRenamed = Bool
False
                                    , minpEvalOpts :: IO EvalOpts
M.minpEvalOpts    = EvalOpts -> IO EvalOpts
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvalOpts -> IO EvalOpts) -> EvalOpts -> IO EvalOpts
forall a b. (a -> b) -> a -> b
$ Logger -> PPOpts -> EvalOpts
E.EvalOpts Logger
L.quietLogger PPOpts
E.defaultPPOpts
                                    , minpByteReader :: FilePath -> IO ByteString
M.minpByteReader  = FilePath -> IO ByteString
BS.readFile
                                    , minpModuleEnv :: ModuleEnv
M.minpModuleEnv   = ModuleEnv
menv
                                    , minpTCSolver :: Solver
M.minpTCSolver    = Solver
solver
                                    }
                            run :: M.ModuleCmd a -> ME.ModuleEnv -> ExceptT Text IO (a, ME.ModuleEnv)
                            run :: forall a.
ModuleCmd a -> ModuleEnv -> ExceptT Text IO (a, ModuleEnv)
run ModuleCmd a
cmd ModuleEnv
menv = do
                                  (r, _warns) <- IO (Either ModuleError (a, ModuleEnv), [ModuleWarning])
-> ExceptT
     Text IO (Either ModuleError (a, ModuleEnv), [ModuleWarning])
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ModuleError (a, ModuleEnv), [ModuleWarning])
 -> ExceptT
      Text IO (Either ModuleError (a, ModuleEnv), [ModuleWarning]))
-> IO (Either ModuleError (a, ModuleEnv), [ModuleWarning])
-> ExceptT
     Text IO (Either ModuleError (a, ModuleEnv), [ModuleWarning])
forall a b. (a -> b) -> a -> b
$ ModuleCmd a
cmd ModuleCmd a -> ModuleCmd a
forall a b. (a -> b) -> a -> b
$ ModuleEnv -> ModuleInput IO
minp ModuleEnv
menv
                                  either (throwError . T.pack . show . pp) pure r
                        (_, env1)                 <- ModuleCmd (ModulePath, TCTopEntity)
-> ModuleEnv
-> ExceptT Text IO ((ModulePath, TCTopEntity), ModuleEnv)
forall a.
ModuleCmd a -> ModuleEnv -> ExceptT Text IO (a, ModuleEnv)
run (FilePath -> ModuleCmd (ModulePath, TCTopEntity)
M.loadModuleByPath FilePath
file) ModuleEnv
env
                        pe                        <- either (throwError . T.pack . show . P.ppError) pure
                                                          $ P.parseExpr $ fn <> " : " <> ty
                        ((_, texpr, _sch), env2)  <- run (M.checkExpr pe) env1
                        ((spec, _cache), _env3)   <- run (\ ModuleInput IO
mi -> ModuleInput IO
-> ModuleT
     IO ((Expr, [DeclGroup], Map Name (TypesMap Name)), SpecCache)
-> IO
     (Either
        ModuleError
        (((Expr, [DeclGroup], Map Name (TypesMap Name)), SpecCache),
         ModuleEnv),
      [ModuleWarning])
forall (m :: * -> *) a.
Monad m =>
ModuleInput m
-> ModuleT m a
-> m (Either ModuleError (a, ModuleEnv), [ModuleWarning])
MM.runModuleT ModuleInput IO
mi (ModuleT
   IO ((Expr, [DeclGroup], Map Name (TypesMap Name)), SpecCache)
 -> IO
      (Either
         ModuleError
         (((Expr, [DeclGroup], Map Name (TypesMap Name)), SpecCache),
          ModuleEnv),
       [ModuleWarning]))
-> ModuleT
     IO ((Expr, [DeclGroup], Map Name (TypesMap Name)), SpecCache)
-> IO
     (Either
        ModuleError
        (((Expr, [DeclGroup], Map Name (TypesMap Name)), SpecCache),
         ModuleEnv),
      [ModuleWarning])
forall a b. (a -> b) -> a -> b
$ SpecCache
-> SpecT IO (Expr, [DeclGroup], Map Name (TypesMap Name))
-> ModuleT
     IO ((Expr, [DeclGroup], Map Name (TypesMap Name)), SpecCache)
forall (m :: * -> *) a.
SpecCache -> SpecT m a -> ModuleT m (a, SpecCache)
S.runSpecT SpecCache
forall k a. Map k a
Map.empty
                                                            (SpecT IO (Expr, [DeclGroup], Map Name (TypesMap Name))
 -> ModuleT
      IO ((Expr, [DeclGroup], Map Name (TypesMap Name)), SpecCache))
-> SpecT IO (Expr, [DeclGroup], Map Name (TypesMap Name))
-> ModuleT
     IO ((Expr, [DeclGroup], Map Name (TypesMap Name)), SpecCache)
forall a b. (a -> b) -> a -> b
$ [DeclGroup]
-> SpecM Expr
-> SpecT IO (Expr, [DeclGroup], Map Name (TypesMap Name))
forall a.
[DeclGroup]
-> SpecM a -> SpecM (a, [DeclGroup], Map Name (TypesMap Name))
S.withDeclGroups (ModuleEnv -> [DeclGroup]
ME.allDeclGroups ModuleEnv
env2)
                                                            (SpecM Expr
 -> SpecT IO (Expr, [DeclGroup], Map Name (TypesMap Name)))
-> SpecM Expr
-> SpecT IO (Expr, [DeclGroup], Map Name (TypesMap Name))
forall a b. (a -> b) -> a -> b
$ Expr -> SpecM Expr
S.specializeExpr Expr
texpr) env2
                        let (body, dgs, nmap) = spec
                        liftEither $ transClosure entry body dgs nmap (ME.loadedNominalTypes env2) maxNodes

            -- Generous: comfortably fits an AES round or SHA schedule,
            -- but bounds a runaway unrolling.
            defaultMaxNodes :: Integer
            defaultMaxNodes :: Integer
defaultMaxNodes = Integer
2000000

---
--- The specialized closure to Hyle definitions.
---

data TEnv = TEnv
      { TEnv -> HashMap Int (Text, [Type])
tePrims :: HashMap Int (Text, [T.Type]) -- ^ Primitive clones: name and instantiation types.
      , TEnv -> HashMap Int (Text, Sig)
teDefns :: HashMap Int (A.GId, A.Sig)   -- ^ Translated definitions: Hyle name and signature.
      , TEnv -> Map Name Schema
teTypes :: Map.Map N.Name T.Schema      -- ^ Schemas of everything in scope, for type reconstruction.
      , TEnv -> HashMap Int Exp
teScope :: HashMap Int A.Exp            -- ^ Local binders.
      , TEnv -> HashMap Int (NominalType, ConDef)
teCons  :: HashMap Int (T.NominalType, ConDef) -- ^ Struct/enum constructors, by name unique.
      , TEnv -> Int
teDepth :: Int                          -- ^ Case-nesting depth (uniquifies scrutinee lets).
      , TEnv -> HashMap Int (TEnv, Expr)
teFuns  :: HashMap Int (TEnv, T.Expr)   -- ^ Inlinable bindings (higher-order or otherwise
                                                --   un-Hyle-able definitions, local functions), with
                                                --   the environment closed over at the binding.
      , TEnv -> HashMap Int Integer
teInts  :: HashMap Int Integer          -- ^ Constant Integer-typed binders (unrolled
                                                --   comprehension indices); see 'intVal'.
      , TEnv -> HashMap Int (TEnv, Expr)
teStrms :: HashMap Int (TEnv, T.Expr)   -- ^ Infinite-stream local bindings (a recursive
                                                --   @[inf]@ definition), demand-unrolled by 'infPrefix'.
      }

-- | A nominal-type constructor: a struct/newtype's (transparent), or an
--   enum's (tagged).
type ConDef = Either T.StructCon T.EnumCon

-- | The node-count ceiling: unrolling (comprehensions x recursion x
--   folds) can explode, so a translation past this many Hyle nodes fails
--   with an actionable message rather than hanging a downstream tool.
--   Generous by default; raise it with @RWC_CRY_MAX_NODES@ (passed in as
--   the bound, so 0 disables it).
transClosure :: Text -> T.Expr -> [T.DeclGroup] -> Map.Map N.Name (TM.TypesMap N.Name) -> Map.Map N.Name T.NominalType -> Integer -> Either Text ([A.Defn], [Text])
transClosure :: Text
-> Expr
-> [DeclGroup]
-> Map Name (TypesMap Name)
-> Map Name NominalType
-> Integer
-> Either Text ([Defn], [Text])
transClosure Text
entry Expr
body [DeclGroup]
dgs Map Name (TypesMap Name)
nmap Map Name NominalType
noms Integer
maxNodes = do
      decls <- [DeclGroup] -> Either Text [Decl]
orderDecls [DeclGroup]
dgs
      entryName <- case spine body of
            (T.EVar Name
x, [Type]
_, [Expr]
_) -> Name -> Either Text Name
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
x
            (Expr, [Type], [Expr])
_                -> Text -> Either Text Name
forall a b. a -> Either a b
Left Text
"cryptol: unexpected expression shape after specialization (rwcry bug)."
      let primSet = [(Int, ())] -> HashMap Int ()
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [ (Name -> Int
N.nameUnique (Name -> Int) -> Name -> Int
forall a b. (a -> b) -> a -> b
$ Decl -> Name
T.dName Decl
d, ()) | Decl
d <- [Decl]
decls, DeclDef -> Bool
isPrim (DeclDef -> Bool) -> DeclDef -> Bool
forall a b. (a -> b) -> a -> b
$ Decl -> DeclDef
T.dDefinition Decl
d ]
          prims   = [(Int, (Text, [Type]))] -> HashMap Int (Text, [Type])
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [ (Name -> Int
N.nameUnique Name
cl, (Ident -> Text
I.identText (Ident -> Text) -> Ident -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Ident
N.nameIdent Name
orig, [Type]
tys))
                                | (Name
orig, TypesMap Name
tm) <- Map Name (TypesMap Name) -> [(Name, TypesMap Name)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Name (TypesMap Name)
nmap
                                , ([Type]
tys, Name
cl)  <- TypesMap Name -> [([Type], Name)]
forall a. List TypeMap a -> [([Type], a)]
forall (m :: * -> *) k a. TrieMap m k => m a -> [(k, a)]
TM.toListTM TypesMap Name
tm
                                , Name -> Int
N.nameUnique Name
cl Int -> HashMap Int () -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`HM.member` HashMap Int ()
primSet
                                ]
          exprDs  = [ (Decl
d, Expr
e) | Decl
d <- [Decl]
decls, Expr
e <- DeclDef -> [Expr]
defBody (Decl -> DeclDef
T.dDefinition Decl
d) ]
          -- Definitions whose signature fits Hyle become Hyle definitions
          -- (numbered over the full list, for name stability); the rest
          -- (higher-order, or otherwise unrepresentable) are inlined at
          -- their (fully applied) use sites.
          fits    = [ (Int
i, (Decl, Expr)
de) | (Int
i, de :: (Decl, Expr)
de@(Decl
d, Expr
_)) <- [Int] -> [(Decl, Expr)] -> [(Int, (Decl, Expr))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [(Decl, Expr)]
exprDs, Decl -> Bool
hyleable Decl
d ]
          inls    = [ (Decl, Expr)
de | de :: (Decl, Expr)
de@(Decl
d, Expr
_) <- [(Decl, Expr)]
exprDs, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Decl -> Bool
hyleable Decl
d ]
          isEntry Name
x = Name -> Int
N.nameUnique Name
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Int
N.nameUnique Name
entryName
      unless (any (isEntry . T.dName . fst) exprDs)
            $ Left "cryptol: the requested function is a Cryptol primitive; wrap it in a Cryptol definition."
      unless (any (isEntry . T.dName . fst . snd) fits)
            $ Left "cryptol: the requested function's type is not representable at the FFI boundary (words, vectors, and tuples only)."
      names <- HM.fromList <$> mapM (uncurry $ mkName entryName) fits
      let env = TEnv { tePrims :: HashMap Int (Text, [Type])
tePrims = HashMap Int (Text, [Type])
prims
                     , teDefns :: HashMap Int (Text, Sig)
teDefns = HashMap Int (Text, Sig)
names
                     , teTypes :: Map Name Schema
teTypes = [(Name, Schema)] -> Map Name Schema
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Schema)] -> Map Name Schema)
-> [(Name, Schema)] -> Map Name Schema
forall a b. (a -> b) -> a -> b
$ [ (Decl -> Name
T.dName Decl
d, Decl -> Schema
T.dSignature Decl
d) | Decl
d <- [Decl]
decls ]
                                             [(Name, Schema)] -> [(Name, Schema)] -> [(Name, Schema)]
forall a. Semigroup a => a -> a -> a
<> (NominalType -> [(Name, Schema)])
-> [NominalType] -> [(Name, Schema)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NominalType -> [(Name, Schema)]
T.nominalTypeConTypes (Map Name NominalType -> [NominalType]
forall k a. Map k a -> [a]
Map.elems Map Name NominalType
noms)
                     , teScope :: HashMap Int Exp
teScope = HashMap Int Exp
forall a. Monoid a => a
mempty
                     , teCons :: HashMap Int (NominalType, ConDef)
teCons  = [(Int, (NominalType, ConDef))] -> HashMap Int (NominalType, ConDef)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Int, (NominalType, ConDef))]
 -> HashMap Int (NominalType, ConDef))
-> [(Int, (NominalType, ConDef))]
-> HashMap Int (NominalType, ConDef)
forall a b. (a -> b) -> a -> b
$ (NominalType -> [(Int, (NominalType, ConDef))])
-> [NominalType] -> [(Int, (NominalType, ConDef))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NominalType -> [(Int, (NominalType, ConDef))]
conEntries ([NominalType] -> [(Int, (NominalType, ConDef))])
-> [NominalType] -> [(Int, (NominalType, ConDef))]
forall a b. (a -> b) -> a -> b
$ Map Name NominalType -> [NominalType]
forall k a. Map k a -> [a]
Map.elems Map Name NominalType
noms
                     , teDepth :: Int
teDepth = Int
0
                     , teFuns :: HashMap Int (TEnv, Expr)
teFuns  = [(Int, (TEnv, Expr))] -> HashMap Int (TEnv, Expr)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [ (Name -> Int
N.nameUnique (Name -> Int) -> Name -> Int
forall a b. (a -> b) -> a -> b
$ Decl -> Name
T.dName Decl
d, (TEnv
env, Expr
e)) | (Decl
d, Expr
e) <- [(Decl, Expr)]
inls ]
                     , teInts :: HashMap Int Integer
teInts  = HashMap Int Integer
forall a. Monoid a => a
mempty
                     , teStrms :: HashMap Int (TEnv, Expr)
teStrms = HashMap Int (TEnv, Expr)
forall a. Monoid a => a
mempty
                     }
      defns <- mapM (transDecl env . snd) fits
      let nodes = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ (Defn -> Integer) -> [Defn] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Integer
nodeCount (Exp -> Integer) -> (Defn -> Exp) -> Defn -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defn -> Exp
A.defnBody) [Defn]
defns
      unless (maxNodes <= 0 || nodes <= maxNodes)
            $ Left $ "cryptol: the translation of " <> entry <> " is very large ("
                  <> showt nodes <> " nodes, over the " <> showt maxNodes
                  <> "-node limit): an unrolled comprehension, fold, or recursion may be too big to realize."
                  <> " Raise RWC_CRY_MAX_NODES to allow it."
      pure (defns, warnUses prims decls)
      where isPrim :: T.DeclDef -> Bool
            isPrim :: DeclDef -> Bool
isPrim = \ case
                  DeclDef
T.DPrim -> Bool
True
                  DeclDef
_       -> Bool
False

            hyleable :: T.Decl -> Bool
            hyleable :: Decl -> Bool
hyleable = (Text -> Bool)
-> (([Size], Size) -> Bool) -> Either Text ([Size], Size) -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> Text -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> ([Size], Size) -> Bool
forall a b. a -> b -> a
const Bool
True) (Either Text ([Size], Size) -> Bool)
-> (Decl -> Either Text ([Size], Size)) -> Decl -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> Either Text ([Size], Size)
sigWidths (Schema -> Either Text ([Size], Size))
-> (Decl -> Schema) -> Decl -> Either Text ([Size], Size)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decl -> Schema
T.dSignature

            -- A translatable body: an ordinary definition, or a Cryptol
            -- foreign (C FFI) function's Cryptol fallback implementation.
            defBody :: T.DeclDef -> [T.Expr]
            defBody :: DeclDef -> [Expr]
defBody = \ case
                  T.DExpr Expr
e             -> [Expr
e]
                  T.DForeign FFI
_ (Just Expr
e) -> [Expr
e]
                  DeclDef
_                     -> []

            conEntries :: T.NominalType -> [(Int, (T.NominalType, ConDef))]
            conEntries :: NominalType -> [(Int, (NominalType, ConDef))]
conEntries NominalType
nt = case NominalType -> NominalTypeDef
T.ntDef NominalType
nt of
                  T.Struct StructCon
sc -> [ (Name -> Int
N.nameUnique (Name -> Int) -> Name -> Int
forall a b. (a -> b) -> a -> b
$ StructCon -> Name
T.ntConName StructCon
sc, (NominalType
nt, StructCon -> ConDef
forall a b. a -> Either a b
Left StructCon
sc)) ]
                  T.Enum [EnumCon]
ecs  -> [ (Name -> Int
N.nameUnique (Name -> Int) -> Name -> Int
forall a b. (a -> b) -> a -> b
$ EnumCon -> Name
T.ecName EnumCon
ec, (NominalType
nt, EnumCon -> ConDef
forall a b. b -> Either a b
Right EnumCon
ec)) | EnumCon
ec <- [EnumCon]
ecs ]
                  NominalTypeDef
T.Abstract  -> []

            mkName :: N.Name -> Int -> (T.Decl, T.Expr) -> Either Text (Int, (A.GId, A.Sig))
            mkName :: Name -> Int -> (Decl, Expr) -> Either Text (Int, (Text, Sig))
mkName Name
entryName Int
i (Decl
d, Expr
_) = do
                  (aszs, rsz) <- Schema -> Either Text ([Size], Size)
sigWidths (Schema -> Either Text ([Size], Size))
-> Schema -> Either Text ([Size], Size)
forall a b. (a -> b) -> a -> b
$ Decl -> Schema
T.dSignature Decl
d
                  let gid | Name -> Int
N.nameUnique (Decl -> Name
T.dName Decl
d) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Int
N.nameUnique Name
entryName = Text
entry
                          | Bool
otherwise = Text
entry Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
sanitize (Ident -> Text
I.identText (Ident -> Text) -> Ident -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Ident
N.nameIdent (Name -> Ident) -> Name -> Ident
forall a b. (a -> b) -> a -> b
$ Decl -> Name
T.dName Decl
d) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
i
                  pure (N.nameUnique $ T.dName d, (gid, A.Sig noAnn aszs rsz))

-- | Flatten declaration groups in dependency order. A recursive group is
--   re-analyzed after specialization: type-indexed recursion (each call
--   at a strictly smaller instantiation) arrives as a chain of distinct
--   clones, so an acyclic group is ordinary code; a genuine cycle (value
--   recursion) is rejected.
orderDecls :: [T.DeclGroup] -> Either Text [T.Decl]
orderDecls :: [DeclGroup] -> Either Text [Decl]
orderDecls = ([[Decl]] -> [Decl]) -> Either Text [[Decl]] -> Either Text [Decl]
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Decl]] -> [Decl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Either Text [[Decl]] -> Either Text [Decl])
-> ([DeclGroup] -> Either Text [[Decl]])
-> [DeclGroup]
-> Either Text [Decl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DeclGroup -> Either Text [Decl])
-> [DeclGroup] -> Either Text [[Decl]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DeclGroup -> Either Text [Decl]
go
      where go :: T.DeclGroup -> Either Text [T.Decl]
            go :: DeclGroup -> Either Text [Decl]
go = \ case
                  T.NonRecursive Decl
d -> [Decl] -> Either Text [Decl]
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Decl
d]
                  T.Recursive [Decl]
ds   -> (SCC Decl -> Either Text Decl) -> [SCC Decl] -> Either Text [Decl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM SCC Decl -> Either Text Decl
unSCC ([SCC Decl] -> Either Text [Decl])
-> [SCC Decl] -> Either Text [Decl]
forall a b. (a -> b) -> a -> b
$ [Decl] -> [SCC Decl]
sccDecls [Decl]
ds

            unSCC :: SCC T.Decl -> Either Text T.Decl
            unSCC :: SCC Decl -> Either Text Decl
unSCC = \ case
                  AcyclicSCC Decl
d -> Decl -> Either Text Decl
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Decl
d
                  CyclicSCC [Decl]
ds -> Text -> Either Text Decl
forall a b. a -> Either a b
Left (Text -> Either Text Decl) -> Text -> Either Text Decl
forall a b. (a -> b) -> a -> b
$ [Decl] -> Text
noRecMsg [Decl]
ds

-- | Strongly connected components of a recursive group, in dependency
--   order.
sccDecls :: [T.Decl] -> [SCC T.Decl]
sccDecls :: [Decl] -> [SCC Decl]
sccDecls [Decl]
ds = [(Decl, Int, [Int])] -> [SCC Decl]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp
      [ (Decl
d, Name -> Int
N.nameUnique (Name -> Int) -> Name -> Int
forall a b. (a -> b) -> a -> b
$ Decl -> Name
T.dName Decl
d, (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> HashMap Int () -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`HM.member` HashMap Int ()
us) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Name -> Int) -> [Name] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Int
N.nameUnique ([Name] -> [Int]) -> [Name] -> [Int]
forall a b. (a -> b) -> a -> b
$ Decl -> [Name]
declRefs Decl
d) | Decl
d <- [Decl]
ds ]
      where us :: HashMap Int ()
us = [(Int, ())] -> HashMap Int ()
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [ (Name -> Int
N.nameUnique (Name -> Int) -> Name -> Int
forall a b. (a -> b) -> a -> b
$ Decl -> Name
T.dName Decl
d, ()) | Decl
d <- [Decl]
ds ]

noRecMsg :: [T.Decl] -> Text
noRecMsg :: [Decl] -> Text
noRecMsg [Decl]
ds = Text
"cryptol: recursive definitions are not supported: "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " ((Decl -> Text) -> [Decl] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Ident -> Text
I.identText (Ident -> Text) -> (Decl -> Ident) -> Decl -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Ident
N.nameIdent (Name -> Ident) -> (Decl -> Name) -> Decl -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decl -> Name
T.dName) [Decl]
ds)

-- | Names referenced by a declaration/expression (for the post-
--   specialization recursion analysis).
declRefs :: T.Decl -> [N.Name]
declRefs :: Decl -> [Name]
declRefs Decl
d = case Decl -> DeclDef
T.dDefinition Decl
d of
      T.DExpr Expr
e             -> Expr -> [Name]
refs Expr
e
      T.DForeign FFI
_ (Just Expr
e) -> Expr -> [Name]
refs Expr
e
      DeclDef
_                     -> []
      where refs :: T.Expr -> [N.Name]
            refs :: Expr -> [Name]
refs = \ case
                  T.EList [Expr]
es Type
_       -> (Expr -> [Name]) -> [Expr] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Expr -> [Name]
refs [Expr]
es
                  T.ETuple [Expr]
es        -> (Expr -> [Name]) -> [Expr] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Expr -> [Name]
refs [Expr]
es
                  T.ERec RecordMap Ident Expr
fs          -> (Expr -> [Name]) -> [Expr] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Expr -> [Name]
refs ([Expr] -> [Name]) -> [Expr] -> [Name]
forall a b. (a -> b) -> a -> b
$ RecordMap Ident Expr -> [Expr]
forall a b. RecordMap a b -> [b]
recordElements RecordMap Ident Expr
fs
                  T.ESel Expr
e Selector
_         -> Expr -> [Name]
refs Expr
e
                  T.ESet Type
_ Expr
e Selector
_ Expr
v     -> Expr -> [Name]
refs Expr
e [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> Expr -> [Name]
refs Expr
v
                  T.EIf Expr
c Expr
t Expr
f        -> Expr -> [Name]
refs Expr
c [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> Expr -> [Name]
refs Expr
t [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> Expr -> [Name]
refs Expr
f
                  T.ECase Expr
e Map Ident CaseAlt
as Maybe CaseAlt
dl    -> Expr -> [Name]
refs Expr
e [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> (CaseAlt -> [Name]) -> [CaseAlt] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CaseAlt -> [Name]
altRefs (Map Ident CaseAlt -> [CaseAlt]
forall k a. Map k a -> [a]
Map.elems Map Ident CaseAlt
as) [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> [Name] -> (CaseAlt -> [Name]) -> Maybe CaseAlt -> [Name]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] CaseAlt -> [Name]
altRefs Maybe CaseAlt
dl
                  T.EComp Type
_ Type
_ Expr
e [[Match]]
mss  -> Expr -> [Name]
refs Expr
e [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> ([Match] -> [Name]) -> [[Match]] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Match -> [Name]) -> [Match] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Match -> [Name]
matchRefs) [[Match]]
mss
                  T.EVar Name
x           -> [Name
x]
                  T.ETAbs TParam
_ Expr
e        -> Expr -> [Name]
refs Expr
e
                  T.ETApp Expr
e Type
_        -> Expr -> [Name]
refs Expr
e
                  T.EApp Expr
f Expr
a         -> Expr -> [Name]
refs Expr
f [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> Expr -> [Name]
refs Expr
a
                  T.EAbs Name
_ Type
_ Expr
e       -> Expr -> [Name]
refs Expr
e
                  T.ELocated Range
_ Expr
e     -> Expr -> [Name]
refs Expr
e
                  T.EProofAbs Type
_ Expr
e    -> Expr -> [Name]
refs Expr
e
                  T.EProofApp Expr
e      -> Expr -> [Name]
refs Expr
e
                  T.EWhere Expr
e [DeclGroup]
dgs'    -> Expr -> [Name]
refs Expr
e [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> (Decl -> [Name]) -> [Decl] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl -> [Name]
declRefs ((DeclGroup -> [Decl]) -> [DeclGroup] -> [Decl]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DeclGroup -> [Decl]
T.groupDecls [DeclGroup]
dgs')
                  T.EPropGuards [([Type], Expr)]
gs Type
_ -> (([Type], Expr) -> [Name]) -> [([Type], Expr)] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Expr -> [Name]
refs (Expr -> [Name])
-> (([Type], Expr) -> Expr) -> ([Type], Expr) -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Type], Expr) -> Expr
forall a b. (a, b) -> b
snd) [([Type], Expr)]
gs

            altRefs :: T.CaseAlt -> [N.Name]
            altRefs :: CaseAlt -> [Name]
altRefs (T.CaseAlt [(Name, Type)]
_ Expr
e) = Expr -> [Name]
refs Expr
e

            matchRefs :: T.Match -> [N.Name]
            matchRefs :: Match -> [Name]
matchRefs = \ case
                  T.From Name
_ Type
_ Type
_ Expr
e -> Expr -> [Name]
refs Expr
e
                  T.Let Decl
d'       -> Decl -> [Name]
declRefs Decl
d'

-- | Translate one definition: peel its lambdas into parameters; a
--   point-free definition (fewer lambdas than its type has arguments)
--   gets the shortfall eta-expanded on the Hyle side.
transDecl :: TEnv -> (T.Decl, T.Expr) -> Either Text A.Defn
transDecl :: TEnv -> (Decl, Expr) -> Either Text Defn
transDecl TEnv
env (Decl
d, Expr
e) = do
      (gid, sig@(A.Sig _ aszs _)) <- Either Text (Text, Sig)
-> ((Text, Sig) -> Either Text (Text, Sig))
-> Maybe (Text, Sig)
-> Either Text (Text, Sig)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text (Text, Sig)
forall a b. a -> Either a b
Left Text
"cryptol: unnamed definition (rwcry bug)") (Text, Sig) -> Either Text (Text, Sig)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (Maybe (Text, Sig) -> Either Text (Text, Sig))
-> Maybe (Text, Sig) -> Either Text (Text, Sig)
forall a b. (a -> b) -> a -> b
$ Int -> HashMap Int (Text, Sig) -> Maybe (Text, Sig)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Name -> Int
N.nameUnique (Name -> Int) -> Name -> Int
forall a b. (a -> b) -> a -> b
$ Decl -> Name
T.dName Decl
d) (HashMap Int (Text, Sig) -> Maybe (Text, Sig))
-> HashMap Int (Text, Sig) -> Maybe (Text, Sig)
forall a b. (a -> b) -> a -> b
$ TEnv -> HashMap Int (Text, Sig)
teDefns TEnv
env
      let (params, body) = peel e
          pnames         = [ Int -> Name -> Text
pName Int
i Name
x | (Int
i, (Name
x, Type
_)) <- [Int] -> [(Name, Type)] -> [(Int, (Name, Type))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [(Name, Type)]
params ]
          etas           = [ (Text
"$eta" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
i, Size
sz) | (Int
i, Size
sz) <- Int -> [(Int, Size)] -> [(Int, Size)]
forall a. Int -> [a] -> [a]
drop ([(Name, Type)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Type)]
params) ([(Int, Size)] -> [(Int, Size)]) -> [(Int, Size)] -> [(Int, Size)]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Size] -> [(Int, Size)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [Size]
aszs ]
          scope          = [(Int, Exp)] -> HashMap Int Exp
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [ (Name -> Int
N.nameUnique Name
x, Annote -> Size -> Text -> Exp
A.Var Annote
noAnn Size
sz Text
n)
                                       | ((Name
x, Type
_), Text
n, Size
sz) <- [(Name, Type)] -> [Text] -> [Size] -> [((Name, Type), Text, Size)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [(Name, Type)]
params [Text]
pnames [Size]
aszs ]
          types          = ((Name, Type) -> Map Name Schema -> Map Name Schema)
-> Map Name Schema -> [(Name, Type)] -> Map Name Schema
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Name
x, Type
t) -> Name -> Schema -> Map Name Schema -> Map Name Schema
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
x (Type -> Schema
T.tMono Type
t)) (TEnv -> Map Name Schema
teTypes TEnv
env) [(Name, Type)]
params
          env'           = TEnv
env { teScope = scope <> teScope env, teTypes = types }
      body' <- transExp env' (map (uncurry (A.Var noAnn) . swap2) etas) body
      pure $ A.Defn noAnn gid sig (pnames <> map fst etas) body' False (A.Blind [])
      where peel :: T.Expr -> ([(N.Name, T.Type)], T.Expr)
            peel :: Expr -> ([(Name, Type)], Expr)
peel = \ case
                  T.ELocated Range
_ Expr
e'  -> Expr -> ([(Name, Type)], Expr)
peel Expr
e'
                  T.EProofAbs Type
_ Expr
e' -> Expr -> ([(Name, Type)], Expr)
peel Expr
e'
                  T.EAbs Name
x Type
t Expr
e'    -> let ([(Name, Type)]
ps, Expr
b) = Expr -> ([(Name, Type)], Expr)
peel Expr
e' in ((Name
x, Type
t) (Name, Type) -> [(Name, Type)] -> [(Name, Type)]
forall a. a -> [a] -> [a]
: [(Name, Type)]
ps, Expr
b)
                  Expr
e'               -> ([], Expr
e')

            pName :: Int -> N.Name -> A.Name
            pName :: Int -> Name -> Text
pName Int
i Name
x = Text -> Text
sanitize (Ident -> Text
I.identText (Ident -> Text) -> Ident -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Ident
N.nameIdent Name
x) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
i

            swap2 :: (a, b) -> (b, a)
            swap2 :: forall a b. (a, b) -> (b, a)
swap2 (a
a, b
b) = (b
b, a
a)

-- | Translate an expression; @etas@ are pending (already-translated)
--   arguments applied to it: the eta-expansion of a point-free
--   definition, or arguments awaiting a function-valued subexpression
--   (they thread through lambdas, ifs, wheres, and cases).
transExp :: TEnv -> [A.Exp] -> T.Expr -> Either Text A.Exp
transExp :: TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env [Exp]
etas Expr
e0
      | [Exp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Exp]
etas, Just Integer
v <- TEnv -> Expr -> Maybe Integer
intVal TEnv
env Expr
e0 = Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Exp
intLit Integer
v
transExp TEnv
env [Exp]
etas Expr
e0 = case Expr -> (Expr, [Type], [Expr])
spine Expr
e0 of
      (T.EVar Name
x, [Type]
tys, [Expr]
args)
            | Just (NominalType
nt, ConDef
con) <- Int
-> HashMap Int (NominalType, ConDef) -> Maybe (NominalType, ConDef)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Name -> Int
N.nameUnique Name
x) (TEnv -> HashMap Int (NominalType, ConDef)
teCons TEnv
env) -> do
                  Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Exp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Exp]
etas) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text -> Either Text ()
forall a b. a -> Either a b
Left Text
"cryptol: partial application of a constructor cannot cross the Cryptol boundary."
                  args' <- (Expr -> Either Text Exp) -> [Expr] -> Either Text [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env []) [Expr]
args
                  transCon nt con tys args'
            | Just (TEnv
envF, Expr
rhs) <- Int -> HashMap Int (TEnv, Expr) -> Maybe (TEnv, Expr)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Name -> Int
N.nameUnique Name
x) (TEnv -> HashMap Int (TEnv, Expr)
teFuns TEnv
env) ->
                  TEnv -> TEnv -> Expr -> [Expr] -> [Exp] -> Either Text Exp
inline TEnv
env TEnv
envF Expr
rhs [Expr]
args [Exp]
etas
            | Just (Text
pn, [Type]
tys') <- Int -> HashMap Int (Text, [Type]) -> Maybe (Text, [Type])
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Name -> Int
N.nameUnique Name
x) (TEnv -> HashMap Int (Text, [Type])
tePrims TEnv
env)
            , Just Either Text Exp
r <- TEnv -> Text -> [Type] -> [Expr] -> Maybe (Either Text Exp)
infConsume TEnv
env Text
pn [Type]
tys' [Expr]
args -> do
                  Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Exp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Exp]
etas) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: partial application of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" over an infinite stream cannot cross the Cryptol boundary."
                  Either Text Exp
r
            | Just (Text
pn, [Type]
tys') <- Int -> HashMap Int (Text, [Type]) -> Maybe (Text, [Type])
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Name -> Int
N.nameUnique Name
x) (TEnv -> HashMap Int (Text, [Type])
tePrims TEnv
env), Text
pn Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Text
"foldl", Text
"foldr", Text
"scanl"] :: [Text]), Bool -> Bool
not ((Expr -> Bool) -> [Expr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TEnv -> Expr -> Bool
isInfSeq TEnv
env) [Expr]
args) -> do
                  Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Exp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Exp]
etas) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: partial application of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" cannot cross the Cryptol boundary."
                  TEnv -> Text -> [Type] -> [Expr] -> Either Text Exp
transFold TEnv
env Text
pn [Type]
tys' [Expr]
args
            | Bool
otherwise -> do
                  args' <- ([Exp] -> [Exp] -> [Exp]
forall a. Semigroup a => a -> a -> a
<> [Exp]
etas) ([Exp] -> [Exp]) -> Either Text [Exp] -> Either Text [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> Either Text Exp) -> [Expr] -> Either Text [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env []) [Expr]
args
                  apply env x args'
      (Expr
e, [Type]
_, Expr
_ : [Expr]
_)              -> Text -> Either Text Exp
forall a b. a -> Either a b
Left (Text -> Either Text Exp) -> Text -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: unsupported application head" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr -> Text
unsupported Expr
e
      (Expr
e, [Type]
_, [])  -> case Expr
e of
            T.EAbs Name
x Type
t Expr
b
                  | Exp
a : [Exp]
as <- [Exp]
etas -> TEnv -> [Exp] -> Expr -> Either Text Exp
transExp (TEnv -> [(Name, Type, Exp)] -> TEnv
bindAll TEnv
env [(Name
x, Type
t, Exp
a)]) [Exp]
as Expr
b
                  | Bool
otherwise      -> Text -> Either Text Exp
forall a b. a -> Either a b
Left Text
"cryptol: a lambda in argument or result position cannot cross the Cryptol boundary (define it as a named function)."
            T.EIf Expr
c Expr
t Expr
f    -> do
                  c' <- TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env [] Expr
c
                  t' <- transExp env etas t
                  f' <- transExp env etas f
                  pure $ A.If noAnn (A.sizeOf t') c' t' f'
            T.EWhere Expr
e' [DeclGroup]
ds -> TEnv -> [Exp] -> Expr -> [DeclGroup] -> Either Text Exp
transWhere TEnv
env [Exp]
etas Expr
e' [DeclGroup]
ds
            T.ECase Expr
scrut Map Ident CaseAlt
alts Maybe CaseAlt
dflt -> TEnv
-> [Exp]
-> Expr
-> Map Ident CaseAlt
-> Maybe CaseAlt
-> Either Text Exp
transCase TEnv
env [Exp]
etas Expr
scrut Map Ident CaseAlt
alts Maybe CaseAlt
dflt
            Expr
_ | Bool -> Bool
not ([Exp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Exp]
etas) -> Text -> Either Text Exp
forall a b. a -> Either a b
Left (Text -> Either Text Exp) -> Text -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: cannot apply a value as a function" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr -> Text
unsupported Expr
e
            T.ETuple [Expr]
es    -> [Exp] -> Exp
A.cat ([Exp] -> Exp) -> Either Text [Exp] -> Either Text Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> Either Text Exp) -> [Expr] -> Either Text [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env []) [Expr]
es
            T.EList [Expr]
es Type
_   -> [Exp] -> Exp
A.cat ([Exp] -> Exp) -> Either Text [Exp] -> Either Text Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> Either Text Exp) -> [Expr] -> Either Text [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env []) [Expr]
es
            T.ERec RecordMap Ident Expr
fs      -> [Exp] -> Exp
A.cat ([Exp] -> Exp) -> Either Text [Exp] -> Either Text Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> Either Text Exp) -> [Expr] -> Either Text [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env []) (RecordMap Ident Expr -> [Expr]
forall a b. RecordMap a b -> [b]
recordElements RecordMap Ident Expr
fs)
            T.ESel Expr
e' Selector
sel  -> do
                  a'  <- TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env [] Expr
e'
                  sel' env e' a' sel
            T.ESet Type
ty Expr
e' Selector
sel Expr
v -> TEnv -> Type -> Expr -> Selector -> Expr -> Either Text Exp
transSet TEnv
env Type
ty Expr
e' Selector
sel Expr
v
            T.EComp Type
_ Type
ety Expr
body [[Match]]
mss -> TEnv -> Type -> Expr -> [[Match]] -> Either Text Exp
transComp TEnv
env Type
ety Expr
body [[Match]]
mss
            Expr
_              -> Text -> Either Text Exp
forall a b. a -> Either a b
Left (Text -> Either Text Exp) -> Text -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: unsupported expression" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr -> Text
unsupported Expr
e
      where sel' :: TEnv -> T.Expr -> A.Exp -> T.Selector -> Either Text A.Exp
            sel' :: TEnv -> Expr -> Exp -> Selector -> Either Text Exp
sel' TEnv
env' Expr
scrut Exp
a' = \ case
                  T.TupleSel Int
i Maybe Int
_ -> do
                        t  <- TEnv -> Expr -> Either Text Type
exprTy TEnv
env' Expr
scrut
                        ws <- tupleWidths t
                        unless (i < length ws) $ Left "cryptol: tuple selector out of bounds (rwcry bug)."
                        pure $ A.Slice noAnn (fromIntegral $ sum $ drop (i + 1) ws) (fromIntegral $ ws !! i) a'
                  T.ListSel Int
i Maybe Int
_  -> do
                        t        <- TEnv -> Expr -> Either Text Type
exprTy TEnv
env' Expr
scrut
                        (n, we)  <- seqWidths t
                        unless (fromIntegral i < n) $ Left "cryptol: sequence selector out of bounds."
                        pure $ A.Slice noAnn (fromIntegral $ (n - 1 - fromIntegral i) * we) (fromIntegral we) a'
                  T.RecordSel Ident
f Maybe [Ident]
_ -> do
                        t  <- TEnv -> Expr -> Either Text Type
exprTy TEnv
env' Expr
scrut
                        fs <- recFields t
                        case break ((== f) . fst) fs of
                              ([(Ident, Integer)]
_, [])              -> Text -> Either Text Exp
forall a b. a -> Either a b
Left (Text -> Either Text Exp) -> Text -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: unknown record field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ident -> Text
I.identText Ident
f
                              ([(Ident, Integer)]
_, (Ident
_, Integer
w) : [(Ident, Integer)]
post) -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Size) -> Integer -> Size
forall a b. (a -> b) -> a -> b
$ [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ ((Ident, Integer) -> Integer) -> [(Ident, Integer)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, Integer) -> Integer
forall a b. (a, b) -> b
snd [(Ident, Integer)]
post) (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
w) Exp
a'

unsupported :: T.Expr -> Text
unsupported :: Expr -> Text
unsupported Expr
e = Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Doc -> FilePath
forall a. Show a => a -> FilePath
show (Doc -> FilePath) -> Doc -> FilePath
forall a b. (a -> b) -> a -> b
$ Expr -> Doc
forall a. PP a => a -> Doc
pp Expr
e)

-- | Evaluate a constant Integer-typed expression. Unbounded Integers at
--   runtime are unrepresentable in hardware, but the common uses --
--   comprehension indices (@[4 .. 43]@ defaults its elements to Integer)
--   flowing into indexing, arithmetic, and comparisons -- are constants
--   once comprehensions unroll: comprehension binders over constant
--   Integer sequences land in 'teInts', and this folds the arithmetic
--   over them.
intVal :: TEnv -> T.Expr -> Maybe Integer
intVal :: TEnv -> Expr -> Maybe Integer
intVal TEnv
env Expr
e = case Expr -> (Expr, [Type], [Expr])
spine Expr
e of
      (T.EVar Name
x, [Type]
_, [Expr]
args) -> case (Int -> HashMap Int Integer -> Maybe Integer
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Name -> Int
N.nameUnique Name
x) (HashMap Int Integer -> Maybe Integer)
-> HashMap Int Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ TEnv -> HashMap Int Integer
teInts TEnv
env, Int -> HashMap Int (TEnv, Expr) -> Maybe (TEnv, Expr)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Name -> Int
N.nameUnique Name
x) (HashMap Int (TEnv, Expr) -> Maybe (TEnv, Expr))
-> HashMap Int (TEnv, Expr) -> Maybe (TEnv, Expr)
forall a b. (a -> b) -> a -> b
$ TEnv -> HashMap Int (TEnv, Expr)
teFuns TEnv
env, [Expr]
args) of
            (Just Integer
v, Maybe (TEnv, Expr)
_, [])           -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
v
            (Maybe Integer
_, Just (TEnv
envF, Expr
rhs), []) -> TEnv -> Expr -> Maybe Integer
intVal TEnv
envF Expr
rhs
            (Maybe Integer, Maybe (TEnv, Expr), [Expr])
_                         -> do
                  (pn, tys) <- Int -> HashMap Int (Text, [Type]) -> Maybe (Text, [Type])
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Name -> Int
N.nameUnique Name
x) (HashMap Int (Text, [Type]) -> Maybe (Text, [Type]))
-> HashMap Int (Text, [Type]) -> Maybe (Text, [Type])
forall a b. (a -> b) -> a -> b
$ TEnv -> HashMap Int (Text, [Type])
tePrims TEnv
env
                  vs        <- mapM (intVal env) args
                  -- Only at the Integer instance: literals and arithmetic
                  -- at word types translate as words.
                  case (pn, tys, vs) of
                        (Text
"number", [Type
v, Type
rep], []) | Type -> Bool
isInteger Type
rep       -> Type -> Maybe Integer
tyNat Type
v
                        (Text
"+", [Type
t], [Integer
a, Integer
b])       | Type -> Bool
isInteger Type
t         -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
b
                        (Text
"-", [Type
t], [Integer
a, Integer
b])       | Type -> Bool
isInteger Type
t         -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
b
                        (Text
"*", [Type
t], [Integer
a, Integer
b])       | Type -> Bool
isInteger Type
t         -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
b
                        (Text
"/", [Type
t], [Integer
a, Integer
b])       | Type -> Bool
isInteger Type
t, Integer
b Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0 -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
b
                        (Text
"%", [Type
t], [Integer
a, Integer
b])       | Type -> Bool
isInteger Type
t, Integer
b Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0 -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
b
                        (Text
"^^", [Type
t, Type
_], [Integer
a, Integer
b])   | Type -> Bool
isInteger Type
t, Integer
b Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
b
                        (Text
"negate", [Type
t], [Integer
a])     | Type -> Bool
isInteger Type
t         -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => a -> a
negate Integer
a
                        (Text
"toInteger", [Type]
_, [Integer
a])                          -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
a
                        (Text
"max", [Type
t], [Integer
a, Integer
b])     | Type -> Bool
isInteger Type
t         -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
a Integer
b
                        (Text
"min", [Type
t], [Integer
a, Integer
b])     | Type -> Bool
isInteger Type
t         -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min Integer
a Integer
b
                        (Text, [Type], [Integer])
_                                              -> Maybe Integer
forall a. Maybe a
Nothing
      (Expr, [Type], [Expr])
_ -> Maybe Integer
forall a. Maybe a
Nothing

-- | An Integer constant as a Hyle literal, at the width of its value
--   (consumers -- indexing, shift amounts -- extend as needed).
intLit :: Integer -> A.Exp
intLit :: Integer -> Exp
intLit Integer
v = Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> Natural -> Int
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
nbits (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Natural) -> Integer -> Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 Integer
v Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Integer
v

-- | The constant value of a translated expression, folding literal
--   arithmetic (unrolled comprehension indices produce shapes like
--   @sub i 4@ over literals).
litVal :: A.Exp -> Maybe Integer
litVal :: Exp -> Maybe Integer
litVal = \ case
      A.Lit Annote
_ BV
bv          -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ BV -> Integer
nat BV
bv
      A.Slice Annote
_ Size
off Size
w Exp
e   -> do
            v <- Exp -> Maybe Integer
litVal Exp
e
            pure $ (v `div` (2 ^ toInteger off)) `mod` (2 ^ toInteger w)
      A.Cat Annote
_ Exp
l Exp
r         -> do
            lv <- Exp -> Maybe Integer
litVal Exp
l
            rv <- litVal r
            pure $ lv * (2 ^ toInteger (A.sizeOf r)) + rv
      A.Prim Annote
_ Size
w Op
op [Exp]
es    -> do
            vs <- (Exp -> Maybe Integer) -> [Exp] -> Maybe [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Exp -> Maybe Integer
litVal [Exp]
es
            let wrap a
v = a
v a -> a -> a
forall a. Integral a => a -> a -> a
`mod` (a
2 a -> Integer -> a
forall a b. (Num a, Integral b) => a -> b -> a
^ Size -> Integer
forall a. Integral a => a -> Integer
toInteger Size
w)
            case (op, vs) of
                  (Op
A.Add,  [Integer
a, Integer
b])          -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall {a}. Integral a => a -> a
wrap (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
b
                  (Op
A.Sub,  [Integer
a, Integer
b])          -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall {a}. Integral a => a -> a
wrap (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
b
                  (Op
A.Mul,  [Integer
a, Integer
b])          -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall {a}. Integral a => a -> a
wrap (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
b
                  (Op
A.UDiv, [Integer
a, Integer
b]) | Integer
b Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0 -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
b
                  (Op
A.UMod, [Integer
a, Integer
b]) | Integer
b Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0 -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
b
                  (Op
A.Shl,  [Integer
a, Integer
b])          -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall {a}. Integral a => a -> a
wrap (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
b
                  (Op
A.LShr, [Integer
a, Integer
b])          -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer
a Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` (Integer
2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
b)
                  (A.ZExt Size
_,  [Integer
a])          -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
a
                  (A.Trunc Size
_, [Integer
a])          -> Integer -> Maybe Integer
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall {a}. Integral a => a -> a
wrap Integer
a
                  (Op, [Integer])
_                         -> Maybe Integer
forall a. Maybe a
Nothing
      Exp
_                   -> Maybe Integer
forall a. Maybe a
Nothing

-- | Inline an inlinable binding at a use site: parameters with
--   Hyle-representable types bind to their translated arguments; the
--   rest (function-valued or otherwise unrepresentable arguments) are
--   deferred -- recorded against the call-site environment and
--   re-translated at their own use sites. The body translates in the
--   binding's captured environment, at the call site's case-nesting
--   depth (capture along nesting is the only kind possible).
inline :: TEnv -> TEnv -> T.Expr -> [T.Expr] -> [A.Exp] -> Either Text A.Exp
inline :: TEnv -> TEnv -> Expr -> [Expr] -> [Exp] -> Either Text Exp
inline TEnv
site TEnv
defn Expr
rhs [Expr]
args [Exp]
etas = TEnv -> Expr -> [Expr] -> Either Text Exp
go (TEnv
defn { teDepth = teDepth site }) Expr
rhs [Expr]
args
      where go :: TEnv -> T.Expr -> [T.Expr] -> Either Text A.Exp
            go :: TEnv -> Expr -> [Expr] -> Either Text Exp
go TEnv
env Expr
e [Expr]
as = case (Expr -> Expr
skip Expr
e, [Expr]
as) of
                  (T.EAbs Name
x Type
t Expr
b, Expr
a : [Expr]
as')
                        | Right Integer
_ <- Type -> Either Text Integer
tyWidth Type
t -> do
                              a' <- TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
site [] Expr
a
                              go (bindAll env [(x, t, a')]) b as'
                        | Bool
otherwise -> TEnv -> Expr -> [Expr] -> Either Text Exp
go (TEnv
env { teFuns  = HM.insert (N.nameUnique x) (site, a) $ teFuns env
                                               , teTypes = Map.insert x (T.tMono t) $ teTypes env }) Expr
b [Expr]
as'
                  (Expr
b, [])         -> TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env [Exp]
etas Expr
b
                  (Expr
b, [Expr]
_)          -> do
                        as' <- (Expr -> Either Text Exp) -> [Expr] -> Either Text [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
site []) [Expr]
as
                        transExp env (as' <> etas) b

            skip :: T.Expr -> T.Expr
            skip :: Expr -> Expr
skip = \ case
                  T.ELocated Range
_ Expr
e  -> Expr -> Expr
skip Expr
e
                  T.EProofAbs Type
_ Expr
e -> Expr -> Expr
skip Expr
e
                  Expr
e               -> Expr
e

-- | Bind an inlinable function's parameters to arguments without
--   translating the body -- for beta-reducing an applied inf-producing
--   function (e.g. @iterate f z@) so 'infPrefix' can analyze the residual
--   stream expression. Value parameters bind translated; function
--   parameters defer as closures.
betaBind :: TEnv -> TEnv -> T.Expr -> [T.Expr] -> Either Text (TEnv, T.Expr)
betaBind :: TEnv -> TEnv -> Expr -> [Expr] -> Either Text (TEnv, Expr)
betaBind TEnv
site TEnv
env0 Expr
rhs0 [Expr]
args0 = TEnv -> Expr -> [Expr] -> Either Text (TEnv, Expr)
go (TEnv
env0 { teDepth = teDepth site }) Expr
rhs0 [Expr]
args0
      where go :: TEnv -> T.Expr -> [T.Expr] -> Either Text (TEnv, T.Expr)
            go :: TEnv -> Expr -> [Expr] -> Either Text (TEnv, Expr)
go TEnv
env Expr
e [Expr]
as = case (Expr -> Expr
skip Expr
e, [Expr]
as) of
                  (T.EAbs Name
x Type
t Expr
b, Expr
a : [Expr]
as')
                        | Right Integer
_ <- Type -> Either Text Integer
tyWidth Type
t -> do
                              a' <- TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
site [] Expr
a
                              go (bindAll env [(x, t, a')]) b as'
                        | Bool
otherwise -> TEnv -> Expr -> [Expr] -> Either Text (TEnv, Expr)
go (TEnv
env { teFuns  = HM.insert (N.nameUnique x) (site, a) $ teFuns env
                                               , teTypes = Map.insert x (T.tMono t) $ teTypes env }) Expr
b [Expr]
as'
                  (Expr
b, []) -> (TEnv, Expr) -> Either Text (TEnv, Expr)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TEnv
env, Expr
b)
                  (Expr, [Expr])
_       -> Text -> Either Text (TEnv, Expr)
forall a b. a -> Either a b
Left Text
"cryptol: an infinite stream produced by a partially applied function is not supported."

            skip :: T.Expr -> T.Expr
            skip :: Expr -> Expr
skip = \ case
                  T.ELocated Range
_ Expr
e  -> Expr -> Expr
skip Expr
e
                  T.EProofAbs Type
_ Expr
e -> Expr -> Expr
skip Expr
e
                  Expr
e               -> Expr
e

-- | A saturated constructor application (arguments already translated).
--   A struct (newtype) constructor is transparent: the value is its
--   record argument's bits. An enum constructor builds tag\#pad\#args: the
--   constructor's declaration index in nbits(#constructors) bits at the
--   most-significant end, zero padding up to the enum's width, then the
--   argument bits (matching the Eidos fold's ADT layout).
transCon :: T.NominalType -> ConDef -> [T.Type] -> [A.Exp] -> Either Text A.Exp
transCon :: NominalType -> ConDef -> [Type] -> [Exp] -> Either Text Exp
transCon NominalType
nt ConDef
con [Type]
tys [Exp]
args = case ConDef
con of
      Left StructCon
_sc -> case [Exp]
args of
            [Exp
a] -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
a
            [Exp]
_   -> Text -> Either Text Exp
forall a b. a -> Either a b
Left (Text -> Either Text Exp) -> Text -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: a struct constructor expects exactly its record argument: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ntName
      Right EnumCon
ec -> do
            su <- NominalType -> [Type] -> Either Text Subst
paramSubst NominalType
nt [Type]
tys
            let nCons  = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ () | T.Enum [EnumCon]
ecs <- [NominalType -> NominalTypeDef
T.ntDef NominalType
nt], EnumCon
_ <- [EnumCon]
ecs ]
            ftys <- mapM (tyWidth . TS.apSubst su) $ T.ecFields ec
            unless (length args == length ftys)
                  $ Left $ "cryptol: partial application of an enum constructor cannot cross the Cryptol boundary: " <> ntName
            w <- tyWidth $ T.TNominal nt tys
            let tagW   = Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Integer) -> Natural -> Integer
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
nbits (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nCons
                szArgs = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer]
ftys
                padW   = Integer
w Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
tagW Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
szArgs
            unless (padW >= 0) $ Left "cryptol: enum constructor wider than its type (rwcry bug)."
            pure $ A.cat $ [ A.Lit noAnn $ bitVec (fromIntegral tagW) (toInteger $ T.ecNumber ec) | tagW > 0 ]
                        <> [ A.Lit noAnn $ zeros $ fromIntegral padW | padW > 0 ]
                        <> args
      where ntName :: Text
ntName = Ident -> Text
I.identText (Ident -> Text) -> Ident -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Ident
N.nameIdent (Name -> Ident) -> Name -> Ident
forall a b. (a -> b) -> a -> b
$ NominalType -> Name
T.ntName NominalType
nt

-- | A case expression over an enum value: the scrutinee is bound once
--   (the let's name is uniquified by case-nesting depth, the only axis
--   along which capture is possible), the tag slice is compared against
--   each alternative's constructor index in declaration order, and each
--   alternative's binders are bound to slices of the payload. The
--   default alternative (if any) is the final else and may bind the
--   whole scrutinee.
transCase :: TEnv -> [A.Exp] -> T.Expr -> Map.Map I.Ident T.CaseAlt -> Maybe T.CaseAlt -> Either Text A.Exp
transCase :: TEnv
-> [Exp]
-> Expr
-> Map Ident CaseAlt
-> Maybe CaseAlt
-> Either Text Exp
transCase TEnv
env [Exp]
etas Expr
scrut Map Ident CaseAlt
alts Maybe CaseAlt
dflt = do
      st        <- TEnv -> Expr -> Either Text Type
exprTy TEnv
env Expr
scrut
      nt <- case T.tNoUser st of
            T.TNominal NominalType
nt' [Type]
_ -> NominalType -> Either Text NominalType
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NominalType
nt'
            Type
_                -> Text -> Either Text NominalType
forall a b. a -> Either a b
Left (Text -> Either Text NominalType)
-> Text -> Either Text NominalType
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: case on a non-enum type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
tshow Type
st
      ecs <- case T.ntDef nt of
            T.Enum [EnumCon]
ecs -> [EnumCon] -> Either Text [EnumCon]
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [EnumCon]
ecs
            NominalTypeDef
_          -> Text -> Either Text [EnumCon]
forall a b. a -> Either a b
Left (Text -> Either Text [EnumCon]) -> Text -> Either Text [EnumCon]
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: case on a non-enum type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
tshow Type
st
      scrut' <- transExp env [] scrut
      let sw    = Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
scrut'
          tagW  = Natural -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Size) -> Natural -> Size
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
nbits (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ [EnumCon] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EnumCon]
ecs
          sname = Text
"case$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt (TEnv -> Int
teDepth TEnv
env)
          sv    = Annote -> Size -> Text -> Exp
A.Var Annote
noAnn Size
sw Text
sname
          tag   = Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn (Size
sw Size -> Size -> Size
forall a. Num a => a -> a -> a
- Size
tagW) Size
tagW Exp
sv
          env'  = TEnv
env { teDepth = teDepth env + 1 }
      arms   <- sequence [ (toInteger $ T.ecNumber ec, ) <$> alt env' sv a
                         | ec <- ecs, Just a <- [Map.lookup (N.nameIdent $ T.ecName ec) alts] ]
      dflt'  <- traverse (dfltAlt env' sv) dflt
      chain  <- ifChain tagW tag arms dflt'
      pure $ A.Let noAnn (A.sizeOf chain) sname scrut' chain
      where -- An alternative's binders map to payload slices: the fields
            -- sit at the least-significant end, first field first.
            alt :: TEnv -> A.Exp -> T.CaseAlt -> Either Text A.Exp
            alt :: TEnv -> Exp -> CaseAlt -> Either Text Exp
alt TEnv
env' Exp
sv (T.CaseAlt [(Name, Type)]
bs Expr
rhs) = do
                  ws <- ((Name, Type) -> Either Text Integer)
-> [(Name, Type)] -> Either Text [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Type -> Either Text Integer
tyWidth (Type -> Either Text Integer)
-> ((Name, Type) -> Type) -> (Name, Type) -> Either Text Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Type) -> Type
forall a b. (a, b) -> b
snd) [(Name, Type)]
bs
                  let offs  = Int -> [Integer] -> [Integer]
forall a. Int -> [a] -> [a]
drop Int
1 ([Integer] -> [Integer]) -> [Integer] -> [Integer]
forall a b. (a -> b) -> a -> b
$ (Integer -> Integer -> Integer)
-> Integer -> [Integer] -> [Integer]
forall a b. (a -> b -> b) -> b -> [a] -> [b]
scanr Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+) Integer
0 [Integer]
ws
                      binds = [ (Name
x, Type
t, Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
off) (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
w) Exp
sv)
                              | ((Name
x, Type
t), Integer
w, Integer
off) <- [(Name, Type)]
-> [Integer] -> [Integer] -> [((Name, Type), Integer, Integer)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [(Name, Type)]
bs [Integer]
ws [Integer]
offs ]
                  transExp (bindAll env' binds) etas rhs

            -- The default alternative may bind the scrutinee itself.
            dfltAlt :: TEnv -> A.Exp -> T.CaseAlt -> Either Text A.Exp
            dfltAlt :: TEnv -> Exp -> CaseAlt -> Either Text Exp
dfltAlt TEnv
env' Exp
sv (T.CaseAlt [(Name, Type)]
bs Expr
rhs) = case [(Name, Type)]
bs of
                  []       -> TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env' [Exp]
etas Expr
rhs
                  [(Name
x, Type
t)] -> TEnv -> [Exp] -> Expr -> Either Text Exp
transExp (TEnv -> [(Name, Type, Exp)] -> TEnv
bindAll TEnv
env' [(Name
x, Type
t, Exp
sv)]) [Exp]
etas Expr
rhs
                  [(Name, Type)]
_        -> Text -> Either Text Exp
forall a b. a -> Either a b
Left Text
"cryptol: unexpected default case-alternative shape (rwcry bug)."

            ifChain :: A.Size -> A.Exp -> [(Integer, A.Exp)] -> Maybe A.Exp -> Either Text A.Exp
            ifChain :: Size -> Exp -> [(Integer, Exp)] -> Maybe Exp -> Either Text Exp
ifChain Size
tagW Exp
tag [(Integer, Exp)]
arms Maybe Exp
mDflt = case ([(Integer, Exp)]
arms, Maybe Exp
mDflt) of
                  ([], Just Exp
d)          -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
d
                  ([], Maybe Exp
Nothing)         -> Text -> Either Text Exp
forall a b. a -> Either a b
Left Text
"cryptol: a case expression with no alternatives (rwcry bug)."
                  ((Integer
_, Exp
a) : [(Integer, Exp)]
_, Maybe Exp
_) -> do
                        let w :: Size
w = Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
a
                            ([(Integer, Exp)]
initArms, Exp
lastArm) = case Maybe Exp
mDflt of
                                  Just Exp
d  -> ([(Integer, Exp)]
arms, Exp
d)
                                  Maybe Exp
Nothing -> ([(Integer, Exp)] -> [(Integer, Exp)]
forall a. HasCallStack => [a] -> [a]
init [(Integer, Exp)]
arms, (Integer, Exp) -> Exp
forall a b. (a, b) -> b
snd ((Integer, Exp) -> Exp) -> (Integer, Exp) -> Exp
forall a b. (a -> b) -> a -> b
$ [(Integer, Exp)] -> (Integer, Exp)
forall a. HasCallStack => [a] -> a
last [(Integer, Exp)]
arms)
                        Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ ((Integer, Exp) -> Exp -> Exp) -> Exp -> [(Integer, Exp)] -> Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Integer
i, Exp
rhs) Exp
els ->
                                    Annote -> Size -> Exp -> Exp -> Exp -> Exp
A.If Annote
noAnn Size
w (Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
1 Op
A.Eq [Exp
tag, Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
tagW) Integer
i]) Exp
rhs Exp
els)
                              Exp
lastArm [(Integer, Exp)]
initArms

-- | A record (or tuple/sequence) update @{ e | sel = v }@: the bits
--   before and after the selected field are carried over, the field's
--   bits replaced.
transSet :: TEnv -> T.Type -> T.Expr -> T.Selector -> T.Expr -> Either Text A.Exp
transSet :: TEnv -> Type -> Expr -> Selector -> Expr -> Either Text Exp
transSet TEnv
env Type
ty Expr
e Selector
sel Expr
v = do
      w  <- Type -> Either Text Integer
tyWidth Type
ty
      e' <- transExp env [] e
      v' <- transExp env [] v
      (off, fw) <- case sel of
            T.RecordSel Ident
f Maybe [Ident]
_ -> do
                  fs <- Type -> Either Text [(Ident, Integer)]
recFields Type
ty
                  case break ((== f) . fst) fs of
                        ([(Ident, Integer)]
_, [])              -> Text -> Either Text (Integer, Integer)
forall a b. a -> Either a b
Left (Text -> Either Text (Integer, Integer))
-> Text -> Either Text (Integer, Integer)
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: unknown record field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ident -> Text
I.identText Ident
f
                        ([(Ident, Integer)]
_, (Ident
_, Integer
fw) : [(Ident, Integer)]
post) -> (Integer, Integer) -> Either Text (Integer, Integer)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ ((Ident, Integer) -> Integer) -> [(Ident, Integer)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, Integer) -> Integer
forall a b. (a, b) -> b
snd [(Ident, Integer)]
post, Integer
fw)
            T.TupleSel Int
i Maybe Int
_  -> do
                  ws <- Type -> Either Text [Integer]
tupleWidths Type
ty
                  unless (i < length ws) $ Left "cryptol: tuple update selector out of bounds (rwcry bug)."
                  pure (sum $ drop (i + 1) ws, ws !! i)
            T.ListSel Int
i Maybe Int
_   -> do
                  (n, we) <- Type -> Either Text (Integer, Integer)
seqWidths Type
ty
                  unless (fromIntegral i < n) $ Left "cryptol: sequence update selector out of bounds."
                  pure ((n - 1 - fromIntegral i) * we, we)
      let hiW = Integer
w Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
off Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
fw
      pure $ A.cat $ [ A.Slice noAnn (fromIntegral $ off + fw) (fromIntegral hiW) e' | hiW > 0 ]
                  <> [ v' ]
                  <> [ A.Slice noAnn 0 (fromIntegral off) e' | off > 0 ]

-- | Local bindings: representable monomorphic value bindings become
--   Hyle lets; local functions (and unrepresentable local values, e.g.
--   Integer-typed intermediates) are recorded with the environment they
--   close over and inlined at their use sites; recursive groups that
--   survive the post-specialization SCC analysis are recursive sequence
--   definitions, unrolled element-wise by 'recSeqs'.
transWhere :: TEnv -> [A.Exp] -> T.Expr -> [T.DeclGroup] -> Either Text A.Exp
transWhere :: TEnv -> [Exp] -> Expr -> [DeclGroup] -> Either Text Exp
transWhere TEnv
env [Exp]
etas Expr
body [DeclGroup]
dgs = TEnv -> [Either Decl [Decl]] -> Either Text Exp
go TEnv
env ([Either Decl [Decl]] -> Either Text Exp)
-> [Either Decl [Decl]] -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ (DeclGroup -> [Either Decl [Decl]])
-> [DeclGroup] -> [Either Decl [Decl]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DeclGroup -> [Either Decl [Decl]]
items [DeclGroup]
dgs
      where items :: T.DeclGroup -> [Either T.Decl [T.Decl]]
            items :: DeclGroup -> [Either Decl [Decl]]
items = \ case
                  T.NonRecursive Decl
d -> [Decl -> Either Decl [Decl]
forall a b. a -> Either a b
Left Decl
d]
                  T.Recursive [Decl]
ds   -> (SCC Decl -> Either Decl [Decl])
-> [SCC Decl] -> [Either Decl [Decl]]
forall a b. (a -> b) -> [a] -> [b]
map SCC Decl -> Either Decl [Decl]
fromSCC ([SCC Decl] -> [Either Decl [Decl]])
-> [SCC Decl] -> [Either Decl [Decl]]
forall a b. (a -> b) -> a -> b
$ [Decl] -> [SCC Decl]
sccDecls [Decl]
ds

            fromSCC :: SCC T.Decl -> Either T.Decl [T.Decl]
            fromSCC :: SCC Decl -> Either Decl [Decl]
fromSCC = \ case
                  AcyclicSCC Decl
d -> Decl -> Either Decl [Decl]
forall a b. a -> Either a b
Left Decl
d
                  CyclicSCC [Decl]
c  -> [Decl] -> Either Decl [Decl]
forall a b. b -> Either a b
Right [Decl]
c

            go :: TEnv -> [Either T.Decl [T.Decl]] -> Either Text A.Exp
            go :: TEnv -> [Either Decl [Decl]] -> Either Text Exp
go TEnv
env' []              = TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env' [Exp]
etas Expr
body
            -- A recursive group of infinite streams is registered for
            -- demand-driven unrolling (infStream); a recursive group of
            -- finite sequences is unrolled eagerly (recSeqs).
            go TEnv
env' (Right [Decl]
c : [Either Decl [Decl]]
ds)
                  | (Decl -> Bool) -> [Decl] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Decl -> Bool
isInfDecl [Decl]
c   = TEnv -> [Either Decl [Decl]] -> Either Text Exp
go (TEnv -> [Decl] -> TEnv
registerStreams TEnv
env' [Decl]
c) [Either Decl [Decl]]
ds
                  | Bool
otherwise         = do
                        (env'', lets) <- TEnv -> [Decl] -> Either Text (TEnv, [(Text, Exp)])
recSeqs TEnv
env' [Decl]
c
                        rest <- go env'' ds
                        pure $ foldr (\ (Text
x, Exp
rhs) Exp
b -> Annote -> Size -> Text -> Exp -> Exp -> Exp
A.Let Annote
noAnn (Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
b) Text
x Exp
rhs Exp
b) rest lets
            go TEnv
env' (Left Decl
d : [Either Decl [Decl]]
ds) = case Decl -> DeclDef
T.dDefinition Decl
d of
                  T.DExpr Expr
rhs | ([], Type
t) <- Type -> ([Type], Type)
flatFun (Type -> ([Type], Type)) -> Type -> ([Type], Type)
forall a b. (a -> b) -> a -> b
$ Schema -> Type
T.sType (Schema -> Type) -> Schema -> Type
forall a b. (a -> b) -> a -> b
$ Decl -> Schema
T.dSignature Decl
d, Right Integer
_ <- Type -> Either Text Integer
tyWidth Type
t -> do
                        rhs' <- TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env' [] Expr
rhs
                        let x  = Text -> Text
sanitize (Ident -> Text
I.identText (Ident -> Text) -> Ident -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Ident
N.nameIdent (Name -> Ident) -> Name -> Ident
forall a b. (a -> b) -> a -> b
$ Decl -> Name
T.dName Decl
d) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt (Name -> Int
N.nameUnique (Name -> Int) -> Name -> Int
forall a b. (a -> b) -> a -> b
$ Decl -> Name
T.dName Decl
d)
                            sz = Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
rhs'
                        rest <- go env' { teScope = HM.insert (N.nameUnique $ T.dName d) (A.Var noAnn sz x) $ teScope env'
                                        , teTypes = Map.insert (T.dName d) (T.dSignature d) $ teTypes env'
                                        } ds
                        pure $ A.Let noAnn (A.sizeOf rest) x rhs' rest
                  T.DExpr Expr
rhs -> TEnv -> [Either Decl [Decl]] -> Either Text Exp
go TEnv
env' { teFuns  = HM.insert (N.nameUnique $ T.dName d) (env', rhs) $ teFuns env'
                                         , teTypes = Map.insert (T.dName d) (T.dSignature d) $ teTypes env'
                                         } [Either Decl [Decl]]
ds
                  DeclDef
_         -> Text -> Either Text Exp
forall a b. a -> Either a b
Left Text
"cryptol: unsupported local binding."

            isInfDecl :: T.Decl -> Bool
            isInfDecl :: Decl -> Bool
isInfDecl Decl
d = case (Type -> ([Type], Type)
flatFun (Type -> ([Type], Type)) -> Type -> ([Type], Type)
forall a b. (a -> b) -> a -> b
$ Schema -> Type
T.sType (Schema -> Type) -> Schema -> Type
forall a b. (a -> b) -> a -> b
$ Decl -> Schema
T.dSignature Decl
d, Decl -> DeclDef
T.dDefinition Decl
d) of
                  (([], Type
t), T.DExpr Expr
_) -> case Type -> Type
T.tNoUser Type
t of
                        T.TCon (T.TC TC
T.TCSeq) [Type
n, Type
_] -> case Type -> Type
T.tNoUser Type
n of
                              T.TCon (T.TC TC
T.TCInf) [] -> Bool
True
                              Type
_                        -> Bool
False
                        Type
_ -> Bool
False
                  (([Type], Type), DeclDef)
_ -> Bool
False

            -- Register a recursive group of infinite streams for
            -- demand-driven unrolling, knot-tying the environment so that
            -- (mutual) self-references resolve back to the group.
            registerStreams :: TEnv -> [T.Decl] -> TEnv
            registerStreams :: TEnv -> [Decl] -> TEnv
registerStreams TEnv
e0 [Decl]
c = TEnv
e1
                  where e1 :: TEnv
e1 = TEnv
e0 { teStrms = HM.fromList [ (N.nameUnique $ T.dName d, (e1, rhs)) | d <- c, T.DExpr rhs <- [T.dDefinition d] ] <> teStrms e0
                               , teTypes = Map.fromList [ (T.dName d, T.dSignature d) | d <- c ] <> teTypes e0 }

-- | A cyclic group of local value bindings, each a finite sequence: the
--   recursive-comprehension idiom (@ys = [iv] # [ f y x | y <- ys | x <-
--   xs ]@ -- CBC chaining, key schedules, message schedules). Each
--   definition's name is bound to the concatenation of fresh per-element
--   variables, the right-hand sides translate against that (so
--   self-references become element references once 'pev' folds the
--   slice/concat algebra), and the elements are let-bound in dependency
--   order; a genuinely cyclic element dependency is rejected.
recSeqs :: TEnv -> [T.Decl] -> Either Text (TEnv, [(A.Name, A.Exp)])
recSeqs :: TEnv -> [Decl] -> Either Text (TEnv, [(Text, Exp)])
recSeqs TEnv
env [Decl]
ds = do
      infos <- (Decl -> Either Text (Int, Integer, Integer, [Text], Expr))
-> [Decl] -> Either Text [(Int, Integer, Integer, [Text], Expr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Decl -> Either Text (Int, Integer, Integer, [Text], Expr)
info [Decl]
ds
      let env' = TEnv
env { teScope = HM.fromList [ (u, A.cat [ A.Var noAnn (fromIntegral we) x | x <- xs ])
                                             | (u, _, we, xs, _) <- infos ] <> teScope env
                     , teTypes = Map.fromList [ (T.dName d, T.dSignature d) | d <- ds ] <> teTypes env
                     }
      elems <- concat <$> mapM (elemsOf env') infos
      let nameSet = [(Text, ())] -> HashMap Text ()
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [ (Text
x, ()) | (Text
x, Exp
_) <- [(Text, Exp)]
elems ]
      lets <- mapM unSCC $ stronglyConnComp
            [ ((x, e), x, [ r | r <- varRefs e, r `HM.member` nameSet ]) | (x, e) <- elems ]
      pure (env', lets)
      where info :: T.Decl -> Either Text (Int, Integer, Integer, [A.Name], T.Expr)
            info :: Decl -> Either Text (Int, Integer, Integer, [Text], Expr)
info Decl
d = case Decl -> DeclDef
T.dDefinition Decl
d of
                  T.DExpr Expr
rhs | ([], Type
t) <- Type -> ([Type], Type)
flatFun (Type -> ([Type], Type)) -> Type -> ([Type], Type)
forall a b. (a -> b) -> a -> b
$ Schema -> Type
T.sType (Schema -> Type) -> Schema -> Type
forall a b. (a -> b) -> a -> b
$ Decl -> Schema
T.dSignature Decl
d
                              , Right (Integer
n, Integer
we) <- Type -> Either Text (Integer, Integer)
seqWidths Type
t ->
                        let base :: Text
base = Text -> Text
sanitize (Ident -> Text
I.identText (Ident -> Text) -> Ident -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Ident
N.nameIdent (Name -> Ident) -> Name -> Ident
forall a b. (a -> b) -> a -> b
$ Decl -> Name
T.dName Decl
d) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt (Name -> Int
N.nameUnique (Name -> Int) -> Name -> Int
forall a b. (a -> b) -> a -> b
$ Decl -> Name
T.dName Decl
d)
                        in (Int, Integer, Integer, [Text], Expr)
-> Either Text (Int, Integer, Integer, [Text], Expr)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Name -> Int
N.nameUnique (Name -> Int) -> Name -> Int
forall a b. (a -> b) -> a -> b
$ Decl -> Name
T.dName Decl
d, Integer
n, Integer
we
                                , [ Text
base Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. TextShow a => a -> Text
showt Integer
i | Integer
i <- [Integer
0 .. Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1] ], Expr
rhs )
                  DeclDef
_ -> Text -> Either Text (Int, Integer, Integer, [Text], Expr)
forall a b. a -> Either a b
Left (Text -> Either Text (Int, Integer, Integer, [Text], Expr))
-> Text -> Either Text (Int, Integer, Integer, [Text], Expr)
forall a b. (a -> b) -> a -> b
$ [Decl] -> Text
noRecMsg [Decl]
ds

            elemsOf :: TEnv -> (Int, Integer, Integer, [A.Name], T.Expr) -> Either Text [(A.Name, A.Exp)]
            elemsOf :: TEnv
-> (Int, Integer, Integer, [Text], Expr)
-> Either Text [(Text, Exp)]
elemsOf TEnv
env' (Int
_, Integer
n, Integer
we, [Text]
xs, Expr
rhs) = do
                  rhs' <- TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env' [] Expr
rhs
                  pure [ (x, pev $ elemSlice n we i rhs') | (i, x) <- zip [0 ..] xs ]

            unSCC :: SCC (A.Name, A.Exp) -> Either Text (A.Name, A.Exp)
            unSCC :: SCC (Text, Exp) -> Either Text (Text, Exp)
unSCC = \ case
                  AcyclicSCC (Text, Exp)
x -> (Text, Exp) -> Either Text (Text, Exp)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text, Exp)
x
                  CyclicSCC [(Text, Exp)]
xs -> Text -> Either Text (Text, Exp)
forall a b. a -> Either a b
Left (Text -> Either Text (Text, Exp))
-> Text -> Either Text (Text, Exp)
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: a recursive sequence definition has a cyclic element dependency: "
                        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (((Text, Exp) -> Text) -> [(Text, Exp)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Exp) -> Text
forall a b. (a, b) -> a
fst [(Text, Exp)]
xs)

-- | Partial evaluation of a translated expression: slice\/concat\/literal
--   algebra plus constant arithmetic. Extracting the elements of a
--   recursive sequence definition relies on this: the element slice of
--   the translated right-hand side must reduce to references to only
--   the element variables it actually depends on, so that the elements
--   admit a dependency order.
pev :: A.Exp -> A.Exp
pev :: Exp -> Exp
pev = \ case
      A.Cat Annote
an Exp
l Exp
r         -> Annote -> Exp -> Exp -> Exp
A.Cat Annote
an (Exp -> Exp
pev Exp
l) (Exp -> Exp
pev Exp
r)
      A.Slice Annote
_ Size
off Size
w Exp
e    -> Integer -> Integer -> Exp -> Exp
sliceE (Size -> Integer
forall a. Integral a => a -> Integer
toInteger Size
off) (Size -> Integer
forall a. Integral a => a -> Integer
toInteger Size
w) (Exp -> Exp
pev Exp
e)
      A.Prim Annote
an Size
w Op
op [Exp]
es    ->
            let e' :: Exp
e' = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
an Size
w Op
op ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp) -> [Exp] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Exp
pev [Exp]
es
            in Exp -> (Integer -> Exp) -> Maybe Integer -> Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Exp
e' (Annote -> BV -> Exp
A.Lit Annote
an (BV -> Exp) -> (Integer -> BV) -> Integer -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
w)) (Maybe Integer -> Exp) -> Maybe Integer -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Maybe Integer
litVal Exp
e'
      A.If Annote
an Size
w Exp
c Exp
t Exp
f      -> case Exp -> Maybe Integer
litVal (Exp -> Maybe Integer) -> Exp -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Exp -> Exp
pev Exp
c of
            Just Integer
v  -> if Integer
v Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0 then Exp -> Exp
pev Exp
t else Exp -> Exp
pev Exp
f
            Maybe Integer
Nothing -> Annote -> Size -> Exp -> Exp -> Exp -> Exp
A.If Annote
an Size
w (Exp -> Exp
pev Exp
c) (Exp -> Exp
pev Exp
t) (Exp -> Exp
pev Exp
f)
      A.Call Annote
an Size
w Text
g [Exp]
es     -> Annote -> Size -> Text -> [Exp] -> Exp
A.Call Annote
an Size
w Text
g ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp) -> [Exp] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Exp
pev [Exp]
es
      A.XCall Annote
an Size
w Text
x [Natural]
gs [Exp]
es -> Annote -> Size -> Text -> [Natural] -> [Exp] -> Exp
A.XCall Annote
an Size
w Text
x [Natural]
gs ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp) -> [Exp] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Exp
pev [Exp]
es
      A.Let Annote
an Size
w Text
x Exp
rhs Exp
b   -> Annote -> Size -> Text -> Exp -> Exp -> Exp
A.Let Annote
an Size
w Text
x (Exp -> Exp
pev Exp
rhs) (Exp -> Exp
pev Exp
b)
      Exp
e                    -> Exp
e

-- | @sliceE off w e@: e[off +: w], pushing the slice through concats,
--   slices, literals, and muxes.
sliceE :: Integer -> Integer -> A.Exp -> A.Exp
sliceE :: Integer -> Integer -> Exp -> Exp
sliceE Integer
off Integer
w Exp
e
      | Integer
w Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0                                = Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros Int
0
      | Integer
off Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0, Integer
w Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Size -> Integer
forall a. Integral a => a -> Integer
toInteger (Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
e) = Exp
e
      | Bool
otherwise = case Exp
e of
            A.Cat Annote
_ Exp
l Exp
r ->
                  let rw :: Integer
rw = Size -> Integer
forall a. Integral a => a -> Integer
toInteger (Size -> Integer) -> Size -> Integer
forall a b. (a -> b) -> a -> b
$ Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
r
                  in if Integer
off Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
rw then Integer -> Integer -> Exp -> Exp
sliceE (Integer
off Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
rw) Integer
w Exp
l
                     else if Integer
off Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
w Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
rw then Integer -> Integer -> Exp -> Exp
sliceE Integer
off Integer
w Exp
r
                     else Annote -> Exp -> Exp -> Exp
A.Cat Annote
noAnn (Integer -> Integer -> Exp -> Exp
sliceE Integer
0 (Integer
off Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
w Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
rw) Exp
l) (Integer -> Integer -> Exp -> Exp
sliceE Integer
off (Integer
rw Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
off) Exp
r)
            A.Slice Annote
_ Size
off' Size
_ Exp
e' -> Integer -> Integer -> Exp -> Exp
sliceE (Integer
off Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Size -> Integer
forall a. Integral a => a -> Integer
toInteger Size
off') Integer
w Exp
e'
            A.Lit Annote
_ BV
bv          -> Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
w) (Integer -> BV) -> Integer -> BV
forall a b. (a -> b) -> a -> b
$ (BV -> Integer
nat BV
bv Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` (Integer
2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
off)) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` (Integer
2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
w)
            A.If Annote
_ Size
_ Exp
c Exp
t Exp
f      -> Annote -> Size -> Exp -> Exp -> Exp -> Exp
A.If Annote
noAnn (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
w) Exp
c (Integer -> Integer -> Exp -> Exp
sliceE Integer
off Integer
w Exp
t) (Integer -> Integer -> Exp -> Exp
sliceE Integer
off Integer
w Exp
f)
            Exp
_                   -> Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
off) (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
w) Exp
e

-- | Variable references in a translated expression.
varRefs :: A.Exp -> [A.Name]
varRefs :: Exp -> [Text]
varRefs = \ case
      A.Var Annote
_ Size
_ Text
x        -> [Text
x]
      A.Cat Annote
_ Exp
l Exp
r        -> Exp -> [Text]
varRefs Exp
l [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Exp -> [Text]
varRefs Exp
r
      A.Slice Annote
_ Size
_ Size
_ Exp
e    -> Exp -> [Text]
varRefs Exp
e
      A.Prim Annote
_ Size
_ Op
_ [Exp]
es    -> (Exp -> [Text]) -> [Exp] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp -> [Text]
varRefs [Exp]
es
      A.Call Annote
_ Size
_ Text
_ [Exp]
es    -> (Exp -> [Text]) -> [Exp] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp -> [Text]
varRefs [Exp]
es
      A.XCall Annote
_ Size
_ Text
_ [Natural]
_ [Exp]
es -> (Exp -> [Text]) -> [Exp] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Exp -> [Text]
varRefs [Exp]
es
      A.If Annote
_ Size
_ Exp
c Exp
t Exp
f     -> Exp -> [Text]
varRefs Exp
c [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Exp -> [Text]
varRefs Exp
t [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Exp -> [Text]
varRefs Exp
f
      A.Let Annote
_ Size
_ Text
_ Exp
rhs Exp
b  -> Exp -> [Text]
varRefs Exp
rhs [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Exp -> [Text]
varRefs Exp
b
      Exp
_                  -> []

-- | The number of nodes in a translated expression (the size governor's
--   metric).
nodeCount :: A.Exp -> Integer
nodeCount :: Exp -> Integer
nodeCount = \ case
      A.Cat Annote
_ Exp
l Exp
r        -> Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Exp -> Integer
nodeCount Exp
l Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Exp -> Integer
nodeCount Exp
r
      A.Slice Annote
_ Size
_ Size
_ Exp
e    -> Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Exp -> Integer
nodeCount Exp
e
      A.Prim Annote
_ Size
_ Op
_ [Exp]
es    -> Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Exp -> Integer) -> [Exp] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Integer
nodeCount [Exp]
es)
      A.Call Annote
_ Size
_ Text
_ [Exp]
es    -> Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Exp -> Integer) -> [Exp] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Integer
nodeCount [Exp]
es)
      A.XCall Annote
_ Size
_ Text
_ [Natural]
_ [Exp]
es -> Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Exp -> Integer) -> [Exp] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Integer
nodeCount [Exp]
es)
      A.If Annote
_ Size
_ Exp
c Exp
t Exp
f     -> Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Exp -> Integer
nodeCount Exp
c Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Exp -> Integer
nodeCount Exp
t Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Exp -> Integer
nodeCount Exp
f
      A.Let Annote
_ Size
_ Text
_ Exp
rhs Exp
b  -> Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Exp -> Integer
nodeCount Exp
rhs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Exp -> Integer
nodeCount Exp
b
      Exp
_                  -> Integer
1

-- | Compile-time warnings from a static scan of the specialized
--   declarations: uses of primitives that translate with a semantic
--   caveat (error\/assert\/undefined as a zero poison; trace as identity).
warnUses :: HashMap Int (Text, [T.Type]) -> [T.Decl] -> [Text]
warnUses :: HashMap Int (Text, [Type]) -> [Decl] -> [Text]
warnUses HashMap Int (Text, [Type])
prims [Decl]
decls = [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ Text
errW   | [Text] -> Bool
hasUse [Text
"error"] ]
      , [ Text
traceW | [Text] -> Bool
hasUse [Text
"trace"] ]
      , [ Text
recipW | [Text] -> Bool
hasUse [Text
"recip", Text
"/."] ]
      ]
      where used :: [Text]
used   = [ Text
pn | Decl
d <- [Decl]
decls, Name
x <- Decl -> [Name]
declRefs Decl
d, Just (Text
pn, [Type]
_) <- [Int -> HashMap Int (Text, [Type]) -> Maybe (Text, [Type])
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Name -> Int
N.nameUnique Name
x) HashMap Int (Text, [Type])
prims] ]
            hasUse :: [Text] -> Bool
hasUse [Text]
ns = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Text]
ns :: [Text])) [Text]
used
            traceW :: Text
traceW = Text
"trace/traceVal is ignored (evaluated in hardware, it is the identity on its result)."
            errW :: Text
errW   = Text
"error/assert/undefined compiled to a zero constant (Hyle has no bottom); "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"the result is defined but meaningless where the error would fire."
            recipW :: Text
recipW = Text
"recip/(/.) at Z p unrolls a Fermat inverse (~2*log2(p) modular multiplies); "
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"for a large modulus this is big -- watch the node budget (RWC_CRY_MAX_NODES)."

-- | Count references to a variable (a let-binding may shadow it).
countVar :: A.Name -> A.Exp -> Int
countVar :: Text -> Exp -> Int
countVar Text
x = \ case
      A.Var Annote
_ Size
_ Text
y        -> if Text
y Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
x then Int
1 else Int
0
      A.Cat Annote
_ Exp
l Exp
r        -> Text -> Exp -> Int
countVar Text
x Exp
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Exp -> Int
countVar Text
x Exp
r
      A.Slice Annote
_ Size
_ Size
_ Exp
e    -> Text -> Exp -> Int
countVar Text
x Exp
e
      A.Prim Annote
_ Size
_ Op
_ [Exp]
es    -> [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Exp -> Int) -> [Exp] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Exp -> Int
countVar Text
x) [Exp]
es
      A.Call Annote
_ Size
_ Text
_ [Exp]
es    -> [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Exp -> Int) -> [Exp] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Exp -> Int
countVar Text
x) [Exp]
es
      A.XCall Annote
_ Size
_ Text
_ [Natural]
_ [Exp]
es -> [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Exp -> Int) -> [Exp] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Exp -> Int
countVar Text
x) [Exp]
es
      A.If Annote
_ Size
_ Exp
c Exp
t Exp
f     -> Text -> Exp -> Int
countVar Text
x Exp
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Exp -> Int
countVar Text
x Exp
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Exp -> Int
countVar Text
x Exp
f
      A.Let Annote
_ Size
_ Text
y Exp
rhs Exp
b  -> Text -> Exp -> Int
countVar Text
x Exp
rhs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Text
y Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
x then Int
0 else Text -> Exp -> Int
countVar Text
x Exp
b)
      Exp
_                  -> Int
0

-- | Substitute an expression for a variable (a let-binding shadows it).
substVar :: A.Name -> A.Exp -> A.Exp -> A.Exp
substVar :: Text -> Exp -> Exp -> Exp
substVar Text
x Exp
s = Exp -> Exp
go
      where go :: Exp -> Exp
go = \ case
                  A.Var Annote
_ Size
_ Text
y        | Text
y Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
x -> Exp
s
                  A.Cat Annote
an Exp
l Exp
r        -> Annote -> Exp -> Exp -> Exp
A.Cat Annote
an (Exp -> Exp
go Exp
l) (Exp -> Exp
go Exp
r)
                  A.Slice Annote
an Size
o Size
w Exp
e    -> Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
an Size
o Size
w (Exp -> Exp
go Exp
e)
                  A.Prim Annote
an Size
w Op
op [Exp]
es   -> Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
an Size
w Op
op ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp) -> [Exp] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Exp
go [Exp]
es
                  A.Call Annote
an Size
w Text
g [Exp]
es    -> Annote -> Size -> Text -> [Exp] -> Exp
A.Call Annote
an Size
w Text
g ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp) -> [Exp] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Exp
go [Exp]
es
                  A.XCall Annote
an Size
w Text
n [Natural]
gs [Exp]
es -> Annote -> Size -> Text -> [Natural] -> [Exp] -> Exp
A.XCall Annote
an Size
w Text
n [Natural]
gs ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp) -> [Exp] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Exp
go [Exp]
es
                  A.If Annote
an Size
w Exp
c Exp
t Exp
f     -> Annote -> Size -> Exp -> Exp -> Exp -> Exp
A.If Annote
an Size
w (Exp -> Exp
go Exp
c) (Exp -> Exp
go Exp
t) (Exp -> Exp
go Exp
f)
                  A.Let Annote
an Size
w Text
y Exp
rhs Exp
b  -> Annote -> Size -> Text -> Exp -> Exp -> Exp
A.Let Annote
an Size
w Text
y (Exp -> Exp
go Exp
rhs) (if Text
y Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
x then Exp
b else Exp -> Exp
go Exp
b)
                  Exp
e                   -> Exp
e

-- | A comprehension, fully unrolled: the lengths are concrete after
--   specialization, so each element of the result is the body translated
--   with the generator variables bound to slices of their (translated)
--   sources. Arms zip; generators within an arm nest (the last one
--   fastest), matching Cryptol's semantics.
transComp :: TEnv -> T.Type -> T.Expr -> [[T.Match]] -> Either Text A.Exp
transComp :: TEnv -> Type -> Expr -> [[Match]] -> Either Text Exp
transComp TEnv
env Type
_ety Expr
body [[Match]]
mss
      | ([Match] -> Bool) -> [[Match]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Match -> Bool) -> [Match] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Match -> Bool
matchIsInf) [[Match]]
mss = TEnv -> Expr -> [[Match]] -> Either Text Exp
transCompInf TEnv
env Expr
body [[Match]]
mss
      | Bool
otherwise = do
            arms <- ([Match]
 -> Either
      Text (Integer, Integer -> Either Text [(Name, Type, Exp)]))
-> [[Match]]
-> Either
     Text [(Integer, Integer -> Either Text [(Name, Type, Exp)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TEnv
-> [Match]
-> Either
     Text (Integer, Integer -> Either Text [(Name, Type, Exp)])
armIter TEnv
env) [[Match]]
mss
            let len = case [(Integer, Integer -> Either Text [(Name, Type, Exp)])]
arms of
                  [] -> Integer
0
                  [(Integer, Integer -> Either Text [(Name, Type, Exp)])]
_  -> [Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ ((Integer, Integer -> Either Text [(Name, Type, Exp)]) -> Integer)
-> [(Integer, Integer -> Either Text [(Name, Type, Exp)])]
-> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, Integer -> Either Text [(Name, Type, Exp)]) -> Integer
forall a b. (a, b) -> a
fst [(Integer, Integer -> Either Text [(Name, Type, Exp)])]
arms
            parts <- mapM (part arms) [0 .. len - 1]
            pure $ A.cat parts
      where part :: [(Integer, Integer -> Either Text [(N.Name, T.Type, A.Exp)])] -> Integer -> Either Text A.Exp
            part :: [(Integer, Integer -> Either Text [(Name, Type, Exp)])]
-> Integer -> Either Text Exp
part [(Integer, Integer -> Either Text [(Name, Type, Exp)])]
arms Integer
k = do
                  binds <- [[(Name, Type, Exp)]] -> [(Name, Type, Exp)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Name, Type, Exp)]] -> [(Name, Type, Exp)])
-> Either Text [[(Name, Type, Exp)]]
-> Either Text [(Name, Type, Exp)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Integer, Integer -> Either Text [(Name, Type, Exp)])
 -> Either Text [(Name, Type, Exp)])
-> [(Integer, Integer -> Either Text [(Name, Type, Exp)])]
-> Either Text [[(Name, Type, Exp)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (((Integer -> Either Text [(Name, Type, Exp)])
-> Integer -> Either Text [(Name, Type, Exp)]
forall a b. (a -> b) -> a -> b
$ Integer
k) ((Integer -> Either Text [(Name, Type, Exp)])
 -> Either Text [(Name, Type, Exp)])
-> ((Integer, Integer -> Either Text [(Name, Type, Exp)])
    -> Integer -> Either Text [(Name, Type, Exp)])
-> (Integer, Integer -> Either Text [(Name, Type, Exp)])
-> Either Text [(Name, Type, Exp)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, Integer -> Either Text [(Name, Type, Exp)])
-> Integer -> Either Text [(Name, Type, Exp)]
forall a b. (a, b) -> b
snd) [(Integer, Integer -> Either Text [(Name, Type, Exp)])]
arms
                  transExp (bindAll env binds) [] body

            matchIsInf :: T.Match -> Bool
            matchIsInf :: Match -> Bool
matchIsInf = \ case
                  T.From Name
_ Type
_ Type
_ Expr
src -> TEnv -> Expr -> Bool
isInfSeq TEnv
env Expr
src
                  T.Let Decl
_          -> Bool
False

-- | A comprehension zipping an infinite arm against a finite one (a
--   finite prefix of an infinite stream is demanded -- the min length is
--   set by the finite arm(s)). Each infinite arm is a single generator;
--   its source's prefix is realized once.
transCompInf :: TEnv -> T.Expr -> [[T.Match]] -> Either Text A.Exp
transCompInf :: TEnv -> Expr -> [[Match]] -> Either Text Exp
transCompInf TEnv
env Expr
body [[Match]]
mss = do
      lens <- [[Integer]] -> [Integer]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Integer]] -> [Integer])
-> Either Text [[Integer]] -> Either Text [Integer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Match] -> Either Text [Integer])
-> [[Match]] -> Either Text [[Integer]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Match] -> Either Text [Integer]
armLen [[Match]]
mss
      len  <- case lens of
            [] -> Text -> Either Text Integer
forall a b. a -> Either a b
Left Text
"cryptol: a comprehension with only infinite arms has unbounded length; take a finite prefix."
            [Integer]
_  -> Integer -> Either Text Integer
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Either Text Integer) -> Integer -> Either Text Integer
forall a b. (a -> b) -> a -> b
$ [Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Integer]
lens
      binders <- mapM (armBinder len) mss
      parts   <- mapM (\ Integer
k -> do
                        binds <- [[(Name, Type, Exp)]] -> [(Name, Type, Exp)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Name, Type, Exp)]] -> [(Name, Type, Exp)])
-> Either Text [[(Name, Type, Exp)]]
-> Either Text [(Name, Type, Exp)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Integer -> Either Text [(Name, Type, Exp)])
 -> Either Text [(Name, Type, Exp)])
-> [Integer -> Either Text [(Name, Type, Exp)]]
-> Either Text [[(Name, Type, Exp)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Integer -> Either Text [(Name, Type, Exp)])
-> Integer -> Either Text [(Name, Type, Exp)]
forall a b. (a -> b) -> a -> b
$ Integer
k) [Integer -> Either Text [(Name, Type, Exp)]]
binders
                        transExp (bindAll env binds) [] body) [0 .. len - 1]
      pure $ A.cat parts
      where -- The finite length contributed by an arm (empty for an
            -- infinite arm).
            armLen :: [T.Match] -> Either Text [Integer]
            armLen :: [Match] -> Either Text [Integer]
armLen [Match]
ms
                  | (Match -> Bool) -> [Match] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Match -> Bool
infFrom [Match]
ms = [Integer] -> Either Text [Integer]
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                  | Bool
otherwise      = do
                        ns <- [Either Text Integer] -> Either Text [Integer]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Either Text Integer
-> (Integer -> Either Text Integer)
-> Maybe Integer
-> Either Text Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text Integer
forall a b. a -> Either a b
Left Text
"cryptol: a comprehension source has a non-literal length.") Integer -> Either Text Integer
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Integer -> Either Text Integer)
-> Maybe Integer -> Either Text Integer
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Integer
tyNat Type
l | T.From Name
_ Type
l Type
_ Expr
_ <- [Match]
ms ]
                        pure [ product ns ]

            infFrom :: T.Match -> Bool
            infFrom :: Match -> Bool
infFrom = \ case { T.From Name
_ Type
_ Type
_ Expr
src -> TEnv -> Expr -> Bool
isInfSeq TEnv
env Expr
src ; Match
_ -> Bool
False }

            armBinder :: Integer -> [T.Match] -> Either Text (Integer -> Either Text [(N.Name, T.Type, A.Exp)])
            armBinder :: Integer
-> [Match]
-> Either Text (Integer -> Either Text [(Name, Type, Exp)])
armBinder Integer
len [Match]
ms = case [Match]
ms of
                  [T.From Name
x Type
_ Type
et Expr
src] | TEnv -> Expr -> Bool
isInfSeq TEnv
env Expr
src -> do
                        es <- TEnv -> Integer -> Expr -> Either Text [Exp]
infPrefix TEnv
env Integer
len Expr
src
                        pure $ \ Integer
k -> Either Text [(Name, Type, Exp)]
-> (Exp -> Either Text [(Name, Type, Exp)])
-> Maybe Exp
-> Either Text [(Name, Type, Exp)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text [(Name, Type, Exp)]
forall a b. a -> Either a b
Left Text
"cryptol: infinite comprehension arm too short (rwcry bug).")
                                            ([(Name, Type, Exp)] -> Either Text [(Name, Type, Exp)]
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Name, Type, Exp)] -> Either Text [(Name, Type, Exp)])
-> (Exp -> [(Name, Type, Exp)])
-> Exp
-> Either Text [(Name, Type, Exp)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Type, Exp) -> [(Name, Type, Exp)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Name, Type, Exp) -> [(Name, Type, Exp)])
-> (Exp -> (Name, Type, Exp)) -> Exp -> [(Name, Type, Exp)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name
x, Type
et, )) (Maybe Exp -> Either Text [(Name, Type, Exp)])
-> Maybe Exp -> Either Text [(Name, Type, Exp)]
forall a b. (a -> b) -> a -> b
$ Integer -> [(Integer, Exp)] -> Maybe Exp
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Integer
k ([(Integer, Exp)] -> Maybe Exp) -> [(Integer, Exp)] -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ [Integer] -> [Exp] -> [(Integer, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0 ..] [Exp]
es
                  [Match]
_ | (Match -> Bool) -> [Match] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Match -> Bool
infFrom [Match]
ms -> Text -> Either Text (Integer -> Either Text [(Name, Type, Exp)])
forall a b. a -> Either a b
Left Text
"cryptol: an infinite comprehension arm must be a single generator (no let or nested generators)."
                  [Match]
_ -> (Integer, Integer -> Either Text [(Name, Type, Exp)])
-> Integer -> Either Text [(Name, Type, Exp)]
forall a b. (a, b) -> b
snd ((Integer, Integer -> Either Text [(Name, Type, Exp)])
 -> Integer -> Either Text [(Name, Type, Exp)])
-> Either
     Text (Integer, Integer -> Either Text [(Name, Type, Exp)])
-> Either Text (Integer -> Either Text [(Name, Type, Exp)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TEnv
-> [Match]
-> Either
     Text (Integer, Integer -> Either Text [(Name, Type, Exp)])
armIter TEnv
env [Match]
ms

-- | One comprehension arm: its iteration count, and the bindings its
--   matches produce at iteration @k@.
armIter :: TEnv -> [T.Match] -> Either Text (Integer, Integer -> Either Text [(N.Name, T.Type, A.Exp)])
armIter :: TEnv
-> [Match]
-> Either
     Text (Integer, Integer -> Either Text [(Name, Type, Exp)])
armIter TEnv
env [Match]
ms = do
      radixes <- (Match -> Either Text (Maybe Integer))
-> [Match] -> Either Text [Maybe Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Match -> Either Text (Maybe Integer)
radix [Match]
ms
      let total = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [ Integer
n | Just Integer
n <- [Maybe Integer]
radixes ]
      pure (total, iter radixes)
      where radix :: T.Match -> Either Text (Maybe Integer)
            radix :: Match -> Either Text (Maybe Integer)
radix = \ case
                  T.From Name
_ Type
l Type
_ Expr
_ -> Either Text (Maybe Integer)
-> (Integer -> Either Text (Maybe Integer))
-> Maybe Integer
-> Either Text (Maybe Integer)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text (Maybe Integer)
forall a b. a -> Either a b
Left Text
"cryptol: a comprehension source has a non-literal length.") (Maybe Integer -> Either Text (Maybe Integer)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Integer -> Either Text (Maybe Integer))
-> (Integer -> Maybe Integer)
-> Integer
-> Either Text (Maybe Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Maybe Integer
forall a. a -> Maybe a
Just) (Maybe Integer -> Either Text (Maybe Integer))
-> Maybe Integer -> Either Text (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Integer
tyNat Type
l
                  T.Let Decl
_        -> Maybe Integer -> Either Text (Maybe Integer)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Integer
forall a. Maybe a
Nothing

            -- Mixed-radix decomposition of @k@ over the From matches
            -- (last fastest); Lets translate in the growing scope.
            iter :: [Maybe Integer] -> Integer -> Either Text [(N.Name, T.Type, A.Exp)]
            iter :: [Maybe Integer] -> Integer -> Either Text [(Name, Type, Exp)]
iter [Maybe Integer]
radixes Integer
k = TEnv -> [(Match, Maybe Integer)] -> Either Text [(Name, Type, Exp)]
go TEnv
env ([Match] -> [Maybe Integer] -> [(Match, Maybe Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Match]
ms [Maybe Integer]
digs)
                  where digs :: [Maybe Integer]
digs = [Maybe Integer] -> Integer -> [Maybe Integer]
idxs [Maybe Integer]
radixes Integer
k

                        go :: TEnv -> [(T.Match, Maybe Integer)] -> Either Text [(N.Name, T.Type, A.Exp)]
                        go :: TEnv -> [(Match, Maybe Integer)] -> Either Text [(Name, Type, Exp)]
go TEnv
_ [] = [(Name, Type, Exp)] -> Either Text [(Name, Type, Exp)]
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                        go TEnv
env' ((Match
m, Maybe Integer
dig) : [(Match, Maybe Integer)]
rest) = do
                              b@(x, t, _) <- case (Match
m, Maybe Integer
dig) of
                                    -- Integer-element generators (index idioms like
                                    -- @i <- [4 .. 43]@ default to Integer) bind each
                                    -- unrolled index to its constant value.
                                    (T.From Name
x' Type
_ Type
et Expr
src, Just Integer
i) | Type -> Bool
isInteger Type
et -> do
                                          vs <- TEnv -> Expr -> Either Text [Integer]
seqIntVals TEnv
env' Expr
src
                                          v  <- maybe (Left "cryptol: comprehension index out of range (rwcry bug).") pure
                                                    $ lookup i $ zip [0 ..] vs
                                          pure (x', et, intLit v)
                                    (T.From Name
x' Type
_ Type
et Expr
src, Just Integer
i) -> do
                                          we   <- Type -> Either Text Integer
tyWidth Type
et
                                          n    <- maybe (Left "cryptol: non-literal length (rwcry bug)") pure . tyNat $ srcLen m
                                          srcA <- transExp env' [] src
                                          pure (x', et, elemSlice n we i srcA)
                                    (T.Let Decl
d, Maybe Integer
_) -> case Decl -> DeclDef
T.dDefinition Decl
d of
                                          T.DExpr Expr
rhs | ([], Type
t') <- Type -> ([Type], Type)
flatFun (Type -> ([Type], Type)) -> Type -> ([Type], Type)
forall a b. (a -> b) -> a -> b
$ Schema -> Type
T.sType (Schema -> Type) -> Schema -> Type
forall a b. (a -> b) -> a -> b
$ Decl -> Schema
T.dSignature Decl
d ->
                                                (Decl -> Name
T.dName Decl
d, Type
t', ) (Exp -> (Name, Type, Exp))
-> Either Text Exp -> Either Text (Name, Type, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env' [] Expr
rhs
                                          DeclDef
_ -> Text -> Either Text (Name, Type, Exp)
forall a b. a -> Either a b
Left Text
"cryptol: unsupported local binding in a comprehension."
                                    (Match, Maybe Integer)
_ -> Text -> Either Text (Name, Type, Exp)
forall a b. a -> Either a b
Left Text
"cryptol: malformed comprehension (rwcry bug)."
                              (b :) <$> go (bindAll env' [(x, t, thd b)]) rest

                        thd :: (a, b, c) -> c
thd (a
_, b
_, c
c) = c
c

                        srcLen :: T.Match -> T.Type
                        srcLen :: Match -> Type
srcLen = \ case
                              T.From Name
_ Type
l Type
_ Expr
_ -> Type
l
                              Match
_              -> Integer -> Type
forall a. Integral a => a -> Type
T.tNum (Integer
0 :: Integer)

            -- Row-major digits: positions align with the From matches.
            idxs :: [Maybe Integer] -> Integer -> [Maybe Integer]
            idxs :: [Maybe Integer] -> Integer -> [Maybe Integer]
idxs [Maybe Integer]
rads Integer
k = [Maybe Integer] -> [Maybe Integer]
forall a. [a] -> [a]
reverse ([Maybe Integer] -> [Maybe Integer])
-> [Maybe Integer] -> [Maybe Integer]
forall a b. (a -> b) -> a -> b
$ [Maybe Integer] -> Integer -> [Maybe Integer]
forall {a}. Integral a => [Maybe a] -> a -> [Maybe a]
go' ([Maybe Integer] -> [Maybe Integer]
forall a. [a] -> [a]
reverse [Maybe Integer]
rads) Integer
k
                  where go' :: [Maybe a] -> a -> [Maybe a]
go' [] a
_ = []
                        go' (Maybe a
Nothing : [Maybe a]
rest) a
k' = Maybe a
forall a. Maybe a
Nothing Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: [Maybe a] -> a -> [Maybe a]
go' [Maybe a]
rest a
k'
                        go' (Just a
n : [Maybe a]
rest) a
k'  = a -> Maybe a
forall a. a -> Maybe a
Just (a
k' a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
n) Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: [Maybe a] -> a -> [Maybe a]
go' [Maybe a]
rest (a
k' a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
n)

-- | Extend the environment with translated bindings (constant
--   Integer-typed binders also land in 'teInts' for 'intVal').
bindAll :: TEnv -> [(N.Name, T.Type, A.Exp)] -> TEnv
bindAll :: TEnv -> [(Name, Type, Exp)] -> TEnv
bindAll TEnv
env [(Name, Type, Exp)]
binds = TEnv
env
      { teScope = HM.fromList [ (N.nameUnique x, a) | (x, _, a) <- binds ] <> teScope env
      , teTypes = foldr (\ (Name
x, Type
t, Exp
_) -> Name -> Schema -> Map Name Schema -> Map Name Schema
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
x (Type -> Schema
T.tMono Type
t)) (teTypes env) binds
      , teInts  = HM.fromList [ (N.nameUnique x, v) | (x, t, a) <- binds, isInteger t, Just v <- [litVal a] ] <> teInts env
      }

-- | The constant values of an Integer-element sequence (an enumeration
--   primitive or a literal list): Integer generators only unroll over
--   constants.
seqIntVals :: TEnv -> T.Expr -> Either Text [Integer]
seqIntVals :: TEnv -> Expr -> Either Text [Integer]
seqIntVals TEnv
env Expr
src = case Expr -> (Expr, [Type], [Expr])
spine Expr
src of
      (T.EVar Name
x, [Type]
_, [])
            | Just (Text
pn, [Type]
tys) <- Int -> HashMap Int (Text, [Type]) -> Maybe (Text, [Type])
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Name -> Int
N.nameUnique Name
x) (HashMap Int (Text, [Type]) -> Maybe (Text, [Type]))
-> HashMap Int (Text, [Type]) -> Maybe (Text, [Type])
forall a b. (a -> b) -> a -> b
$ TEnv -> HashMap Int (Text, [Type])
tePrims TEnv
env
            , Just ([Integer]
vs, Type
_) <- Text -> [Type] -> Maybe ([Integer], Type)
enumVals Text
pn [Type]
tys -> [Integer] -> Either Text [Integer]
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Integer]
vs
      (T.EList [Expr]
es Type
_, [Type]
_, []) -> Either Text [Integer]
-> ([Integer] -> Either Text [Integer])
-> Maybe [Integer]
-> Either Text [Integer]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text [Integer]
forall a b. a -> Either a b
Left Text
msg) [Integer] -> Either Text [Integer]
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Integer] -> Either Text [Integer])
-> Maybe [Integer] -> Either Text [Integer]
forall a b. (a -> b) -> a -> b
$ (Expr -> Maybe Integer) -> [Expr] -> Maybe [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TEnv -> Expr -> Maybe Integer
intVal TEnv
env) [Expr]
es
      (Expr, [Type], [Expr])
_                     -> Text -> Either Text [Integer]
forall a b. a -> Either a b
Left Text
msg
      where msg :: Text
msg = Text
"cryptol: a comprehension over Integer must draw from a constant range or list."

-- | The values and element type of a constant enumeration primitive.
enumVals :: Text -> [T.Type] -> Maybe ([Integer], T.Type)
enumVals :: Text -> [Type] -> Maybe ([Integer], Type)
enumVals Text
pn [Type]
tys = case (Text
pn, [Type]
tys) of
      (Text
"fromTo",                  [Type
f, Type
l, Type
a])          -> Type -> Maybe [Integer] -> Maybe ([Integer], Type)
range Type
a (Maybe [Integer] -> Maybe ([Integer], Type))
-> Maybe [Integer] -> Maybe ([Integer], Type)
forall a b. (a -> b) -> a -> b
$ (\ Integer
fv Integer
lv -> [Integer
fv .. Integer
lv])                  (Integer -> Integer -> [Integer])
-> Maybe Integer -> Maybe (Integer -> [Integer])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe Integer
tyNat Type
f Maybe (Integer -> [Integer]) -> Maybe Integer -> Maybe [Integer]
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Integer
tyNat Type
l
      (Text
"fromToLessThan",          [Type
f, Type
b, Type
a])          -> Type -> Maybe [Integer] -> Maybe ([Integer], Type)
range Type
a (Maybe [Integer] -> Maybe ([Integer], Type))
-> Maybe [Integer] -> Maybe ([Integer], Type)
forall a b. (a -> b) -> a -> b
$ (\ Integer
fv Integer
bv -> [Integer
fv .. Integer
bv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1])              (Integer -> Integer -> [Integer])
-> Maybe Integer -> Maybe (Integer -> [Integer])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe Integer
tyNat Type
f Maybe (Integer -> [Integer]) -> Maybe Integer -> Maybe [Integer]
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Integer
tyNat Type
b
      (Text
"fromToBy",                [Type
f, Type
l, Type
s, Type
a])       -> Type -> Maybe [Integer] -> Maybe ([Integer], Type)
range Type
a (Maybe [Integer] -> Maybe ([Integer], Type))
-> Maybe [Integer] -> Maybe ([Integer], Type)
forall a b. (a -> b) -> a -> b
$ (\ Integer
fv Integer
lv Integer
sv -> [Integer
fv, Integer
fv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
sv .. Integer
lv])      (Integer -> Integer -> Integer -> [Integer])
-> Maybe Integer -> Maybe (Integer -> Integer -> [Integer])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe Integer
tyNat Type
f Maybe (Integer -> Integer -> [Integer])
-> Maybe Integer -> Maybe (Integer -> [Integer])
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Integer
tyNat Type
l Maybe (Integer -> [Integer]) -> Maybe Integer -> Maybe [Integer]
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Integer
tyNat Type
s
      (Text
"fromToByLessThan",        [Type
f, Type
b, Type
s, Type
a])       -> Type -> Maybe [Integer] -> Maybe ([Integer], Type)
range Type
a (Maybe [Integer] -> Maybe ([Integer], Type))
-> Maybe [Integer] -> Maybe ([Integer], Type)
forall a b. (a -> b) -> a -> b
$ (\ Integer
fv Integer
bv Integer
sv -> [Integer
fv, Integer
fv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
sv .. Integer
bv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1])  (Integer -> Integer -> Integer -> [Integer])
-> Maybe Integer -> Maybe (Integer -> Integer -> [Integer])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe Integer
tyNat Type
f Maybe (Integer -> Integer -> [Integer])
-> Maybe Integer -> Maybe (Integer -> [Integer])
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Integer
tyNat Type
b Maybe (Integer -> [Integer]) -> Maybe Integer -> Maybe [Integer]
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Integer
tyNat Type
s
      (Text
"fromToDownBy",            [Type
f, Type
l, Type
s, Type
a])       -> Type -> Maybe [Integer] -> Maybe ([Integer], Type)
range Type
a (Maybe [Integer] -> Maybe ([Integer], Type))
-> Maybe [Integer] -> Maybe ([Integer], Type)
forall a b. (a -> b) -> a -> b
$ (\ Integer
fv Integer
lv Integer
sv -> [Integer
fv, Integer
fv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
sv .. Integer
lv])      (Integer -> Integer -> Integer -> [Integer])
-> Maybe Integer -> Maybe (Integer -> Integer -> [Integer])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe Integer
tyNat Type
f Maybe (Integer -> Integer -> [Integer])
-> Maybe Integer -> Maybe (Integer -> [Integer])
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Integer
tyNat Type
l Maybe (Integer -> [Integer]) -> Maybe Integer -> Maybe [Integer]
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Integer
tyNat Type
s
      (Text
"fromToDownByGreaterThan", [Type
f, Type
b, Type
s, Type
a])       -> Type -> Maybe [Integer] -> Maybe ([Integer], Type)
range Type
a (Maybe [Integer] -> Maybe ([Integer], Type))
-> Maybe [Integer] -> Maybe ([Integer], Type)
forall a b. (a -> b) -> a -> b
$ (\ Integer
fv Integer
bv Integer
sv -> [Integer
fv, Integer
fv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
sv .. Integer
bv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1])  (Integer -> Integer -> Integer -> [Integer])
-> Maybe Integer -> Maybe (Integer -> Integer -> [Integer])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe Integer
tyNat Type
f Maybe (Integer -> Integer -> [Integer])
-> Maybe Integer -> Maybe (Integer -> [Integer])
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Integer
tyNat Type
b Maybe (Integer -> [Integer]) -> Maybe Integer -> Maybe [Integer]
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Integer
tyNat Type
s
      (Text
"fromThenTo",              [Type
f, Type
nx, Type
l, Type
a, Type
_n])  -> Type -> Maybe [Integer] -> Maybe ([Integer], Type)
range Type
a (Maybe [Integer] -> Maybe ([Integer], Type))
-> Maybe [Integer] -> Maybe ([Integer], Type)
forall a b. (a -> b) -> a -> b
$ (\ Integer
fv Integer
nv Integer
lv -> [Integer
fv, Integer
nv .. Integer
lv])           (Integer -> Integer -> Integer -> [Integer])
-> Maybe Integer -> Maybe (Integer -> Integer -> [Integer])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe Integer
tyNat Type
f Maybe (Integer -> Integer -> [Integer])
-> Maybe Integer -> Maybe (Integer -> [Integer])
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Integer
tyNat Type
nx Maybe (Integer -> [Integer]) -> Maybe Integer -> Maybe [Integer]
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Integer
tyNat Type
l
      (Text, [Type])
_                                               -> Maybe ([Integer], Type)
forall a. Maybe a
Nothing
      where range :: T.Type -> Maybe [Integer] -> Maybe ([Integer], T.Type)
            range :: Type -> Maybe [Integer] -> Maybe ([Integer], Type)
range Type
a = ([Integer] -> ([Integer], Type))
-> Maybe [Integer] -> Maybe ([Integer], Type)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Type
a)

-- | Unrolled folds and scans; the function argument is taken
--   untranslated (it may be a reference or a lambda -- there are no
--   function values in Hyle). Each accumulator step is let-bound
--   (fold$\<depth\>$\<k\>) so a step function that uses its accumulator more
--   than once doesn't blow up the term.
transFold :: TEnv -> Text -> [T.Type] -> [T.Expr] -> Either Text A.Exp
transFold :: TEnv -> Text -> [Type] -> [Expr] -> Either Text Exp
transFold TEnv
env Text
pn [Type]
tys [Expr]
args = case (Text
pn, [Type]
tys, [Expr]
args) of
      (Text
"foldl", [Type
n, Type
_b, Type
a], [Expr
f, Expr
z, Expr
xs]) -> do
            (nv, we, xsA, zA) <- Type
-> Type -> Expr -> Expr -> Either Text (Integer, Integer, Exp, Exp)
setup Type
n Type
a Expr
xs Expr
z
            foldChain zA [ \ TEnv
env' Exp
acc -> TEnv -> Expr -> [Exp] -> Either Text Exp
applyFn TEnv
env' Expr
f [Exp
acc, Integer -> Integer -> Integer -> Exp -> Exp
elemSlice Integer
nv Integer
we Integer
i Exp
xsA] | i <- [0 .. nv - 1] ]
      (Text
"foldr", [Type
n, Type
a, Type
_b], [Expr
f, Expr
z, Expr
xs]) -> do
            (nv, we, xsA, zA) <- Type
-> Type -> Expr -> Expr -> Either Text (Integer, Integer, Exp, Exp)
setup Type
n Type
a Expr
xs Expr
z
            foldChain zA [ \ TEnv
env' Exp
acc -> TEnv -> Expr -> [Exp] -> Either Text Exp
applyFn TEnv
env' Expr
f [Integer -> Integer -> Integer -> Exp -> Exp
elemSlice Integer
nv Integer
we Integer
i Exp
xsA, Exp
acc] | i <- [nv - 1, nv - 2 .. 0] ]
      (Text
"scanl", [Type
n, Type
_a, Type
b], [Expr
f, Expr
z, Expr
xs]) -> do
            (nv, we, xsA, zA) <- Type
-> Type -> Expr -> Expr -> Either Text (Integer, Integer, Exp, Exp)
setup Type
n Type
b Expr
xs Expr
z
            scanChain zA [ \ TEnv
env' Exp
acc -> TEnv -> Expr -> [Exp] -> Either Text Exp
applyFn TEnv
env' Expr
f [Exp
acc, Integer -> Integer -> Integer -> Exp -> Exp
elemSlice Integer
nv Integer
we Integer
i Exp
xsA] | i <- [0 .. nv - 1] ]
      (Text, [Type], [Expr])
_ -> Text -> Either Text Exp
forall a b. a -> Either a b
Left (Text -> Either Text Exp) -> Text -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: unsupported use of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (expected a fully applied fold)."
      where setup :: T.Type -> T.Type -> T.Expr -> T.Expr -> Either Text (Integer, Integer, A.Exp, A.Exp)
            setup :: Type
-> Type -> Expr -> Expr -> Either Text (Integer, Integer, Exp, Exp)
setup Type
n Type
el Expr
xs Expr
z = do
                  nv  <- Either Text Integer
-> (Integer -> Either Text Integer)
-> Maybe Integer
-> Either Text Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text Integer
forall a b. a -> Either a b
Left (Text -> Either Text Integer) -> Text -> Either Text Integer
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"): non-literal length.") Integer -> Either Text Integer
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Integer -> Either Text Integer)
-> Maybe Integer -> Either Text Integer
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Integer
tyNat Type
n
                  we  <- tyWidth el
                  xsA <- transExp env [] xs
                  zA  <- transExp env [] z
                  pure (nv, we, xsA, zA)

            env' :: TEnv
            env' :: TEnv
env' = TEnv
env { teDepth = teDepth env + 1 }

            nm :: Int -> A.Name
            nm :: Int -> Text
nm Int
k = Text
"fold$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt (TEnv -> Int
teDepth TEnv
env) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
k

            -- A fold: thread the accumulator through the steps, keeping
            -- only the final value. An intermediate is let-bound only when
            -- its consuming step uses it more than once; a single-use
            -- accumulator inlines, so a plain reduction stays a single
            -- expression (as before scans were let-bound).
            foldChain :: A.Exp -> [TEnv -> A.Exp -> Either Text A.Exp] -> Either Text A.Exp
            foldChain :: Exp -> [TEnv -> Exp -> Either Text Exp] -> Either Text Exp
foldChain Exp
z [TEnv -> Exp -> Either Text Exp]
steps = do
                  let w :: Size
w = Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
z
                  (final, binds) <- (Either Text (Exp, [(Text, Exp)])
 -> (Int, TEnv -> Exp -> Either Text Exp)
 -> Either Text (Exp, [(Text, Exp)]))
-> Either Text (Exp, [(Text, Exp)])
-> [(Int, TEnv -> Exp -> Either Text Exp)]
-> Either Text (Exp, [(Text, Exp)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Size
-> Either Text (Exp, [(Text, Exp)])
-> (Int, TEnv -> Exp -> Either Text Exp)
-> Either Text (Exp, [(Text, Exp)])
stepFold Size
w) ((Exp, [(Text, Exp)]) -> Either Text (Exp, [(Text, Exp)])
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp
z, [])) ([Int]
-> [TEnv -> Exp -> Either Text Exp]
-> [(Int, TEnv -> Exp -> Either Text Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [TEnv -> Exp -> Either Text Exp]
steps)
                  pure $ foldr (\ (Text
x, Exp
rhs) Exp
b -> Annote -> Size -> Text -> Exp -> Exp -> Exp
A.Let Annote
noAnn (Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
b) Text
x Exp
rhs Exp
b) final $ reverse binds

            stepFold :: A.Size -> Either Text (A.Exp, [(A.Name, A.Exp)]) -> (Int, TEnv -> A.Exp -> Either Text A.Exp)
                     -> Either Text (A.Exp, [(A.Name, A.Exp)])
            stepFold :: Size
-> Either Text (Exp, [(Text, Exp)])
-> (Int, TEnv -> Exp -> Either Text Exp)
-> Either Text (Exp, [(Text, Exp)])
stepFold Size
w Either Text (Exp, [(Text, Exp)])
acc (Int
k, TEnv -> Exp -> Either Text Exp
step) = do
                  (cur, binds) <- Either Text (Exp, [(Text, Exp)])
acc
                  body <- step env' $ A.Var noAnn w $ nm k
                  if countVar (nm k) body > 1
                        then pure (body, (nm k, cur) : binds)       -- share the accumulator
                        else pure (substVar (nm k) cur body, binds) -- inline it

            -- A scan: every prefix feeds the output, so each accumulator
            -- is let-bound and referenced by name.
            scanChain :: A.Exp -> [TEnv -> A.Exp -> Either Text A.Exp] -> Either Text A.Exp
            scanChain :: Exp -> [TEnv -> Exp -> Either Text Exp] -> Either Text Exp
scanChain Exp
z [TEnv -> Exp -> Either Text Exp]
steps = do
                  let w :: Size
w = Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
z
                  binds <- Size
-> Int
-> [TEnv -> Exp -> Either Text Exp]
-> Either Text [(Text, Exp)]
goScan Size
w Int
0 [TEnv -> Exp -> Either Text Exp]
steps
                  let allBinds = (Int -> Text
nm Int
0, Exp
z) (Text, Exp) -> [(Text, Exp)] -> [(Text, Exp)]
forall a. a -> [a] -> [a]
: [(Text, Exp)]
binds
                      out      = [Exp] -> Exp
A.cat [ Annote -> Size -> Text -> Exp
A.Var Annote
noAnn Size
w (Text -> Exp) -> Text -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Text
nm Int
k | Int
k <- [Int
0 .. [TEnv -> Exp -> Either Text Exp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TEnv -> Exp -> Either Text Exp]
steps] ]
                  pure $ foldr (\ (Text
x, Exp
rhs) Exp
b -> Annote -> Size -> Text -> Exp -> Exp -> Exp
A.Let Annote
noAnn (Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
b) Text
x Exp
rhs Exp
b) out allBinds

            goScan :: A.Size -> Int -> [TEnv -> A.Exp -> Either Text A.Exp] -> Either Text [(A.Name, A.Exp)]
            goScan :: Size
-> Int
-> [TEnv -> Exp -> Either Text Exp]
-> Either Text [(Text, Exp)]
goScan Size
_ Int
_ []            = [(Text, Exp)] -> Either Text [(Text, Exp)]
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            goScan Size
w Int
k (TEnv -> Exp -> Either Text Exp
step : [TEnv -> Exp -> Either Text Exp]
rest) = do
                  body <- TEnv -> Exp -> Either Text Exp
step TEnv
env' (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Text -> Exp
A.Var Annote
noAnn Size
w (Text -> Exp) -> Text -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Text
nm Int
k
                  ((nm (k + 1), body) :) <$> goScan w (k + 1) rest

-- | Apply a function-position expression (a reference, possibly already
--   partially applied, or a lambda) to translated arguments.
applyFn :: TEnv -> T.Expr -> [A.Exp] -> Either Text A.Exp
applyFn :: TEnv -> Expr -> [Exp] -> Either Text Exp
applyFn TEnv
env Expr
f [Exp]
args = case Expr -> (Expr, [Type], [Expr])
spine Expr
f of
      (T.EVar Name
x, [Type]
tys, [Expr]
pre)
            | Just (NominalType
nt, ConDef
con) <- Int
-> HashMap Int (NominalType, ConDef) -> Maybe (NominalType, ConDef)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Name -> Int
N.nameUnique Name
x) (TEnv -> HashMap Int (NominalType, ConDef)
teCons TEnv
env) -> do
                  pre' <- (Expr -> Either Text Exp) -> [Expr] -> Either Text [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env []) [Expr]
pre
                  transCon nt con tys (pre' <> args)
            | Bool
otherwise -> do
                  pre' <- (Expr -> Either Text Exp) -> [Expr] -> Either Text [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env []) [Expr]
pre
                  apply env x (pre' <> args)
      (l :: Expr
l@(T.EAbs {}), [Type]
_, []) -> TEnv -> Expr -> [Exp] -> Either Text Exp
lam TEnv
env Expr
l [Exp]
args
      (Expr, [Type], [Expr])
_ -> Text -> Either Text Exp
forall a b. a -> Either a b
Left Text
"cryptol: unsupported function argument (use a named function or a lambda)."
      where lam :: TEnv -> T.Expr -> [A.Exp] -> Either Text A.Exp
            lam :: TEnv -> Expr -> [Exp] -> Either Text Exp
lam TEnv
env' (T.EAbs Name
x Type
t Expr
b) (Exp
a : [Exp]
as) = TEnv -> Expr -> [Exp] -> Either Text Exp
lam (TEnv -> [(Name, Type, Exp)] -> TEnv
bindAll TEnv
env' [(Name
x, Type
t, Exp
a)]) Expr
b [Exp]
as
            lam TEnv
env' Expr
b []                    = TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env' [] Expr
b
            lam TEnv
env' Expr
b [Exp]
as                    = TEnv -> Expr -> [Exp] -> Either Text Exp
applyFn TEnv
env' Expr
b [Exp]
as

-- | The element type of an infinite (@[inf]a@) sequence expression, or
--   Nothing if the expression is not an infinite sequence.
seqInfElem :: TEnv -> T.Expr -> Maybe T.Type
seqInfElem :: TEnv -> Expr -> Maybe Type
seqInfElem TEnv
env Expr
e = case Type -> Type
T.tNoUser (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Map Name Schema -> Expr -> Type
T.fastTypeOf (TEnv -> Map Name Schema
teTypes TEnv
env) Expr
e of
      T.TCon (T.TC TC
T.TCSeq) [Type
n, Type
el] | Type -> Bool
isInf Type
n -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
el
      Type
_                                       -> Maybe Type
forall a. Maybe a
Nothing
      where isInf :: Type -> Bool
isInf Type
t = case Type -> Type
T.tNoUser Type
t of
                  T.TCon (T.TC TC
T.TCInf) [] -> Bool
True
                  Type
_                        -> Bool
False

isInfSeq :: TEnv -> T.Expr -> Bool
isInfSeq :: TEnv -> Expr -> Bool
isInfSeq TEnv
env = Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Type -> Bool) -> (Expr -> Maybe Type) -> Expr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TEnv -> Expr -> Maybe Type
seqInfElem TEnv
env

-- | The element type of any sequence type.
seqElemType :: T.Type -> Maybe T.Type
seqElemType :: Type -> Maybe Type
seqElemType Type
t = case Type -> Type
T.tNoUser Type
t of
      T.TCon (T.TC TC
T.TCSeq) [Type
_, Type
el] -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
el
      Type
_                             -> Maybe Type
forall a. Maybe a
Nothing

-- | Consumers of an infinite stream that yield a finite result: a demand
--   bound flows in and 'infPrefix' realizes only that many elements.
--   @take@{k} and a constant @\@@ are the realizable consumers; a
--   variable index, reverse index, or bare @drop@/@\@@ of an infinite
--   stream has unbounded demand and is rejected. Returns Nothing when
--   this is not an infinite-stream consumer (the normal path handles it).
infConsume :: TEnv -> Text -> [T.Type] -> [T.Expr] -> Maybe (Either Text A.Exp)
infConsume :: TEnv -> Text -> [Type] -> [Expr] -> Maybe (Either Text Exp)
infConsume TEnv
env Text
pn [Type]
ptys [Expr]
args = case (Text
pn, [Type]
ptys, [Expr]
args) of
      (Text
"take", [Type
front, Type
_back, Type
_a], [Expr
src]) | TEnv -> Expr -> Bool
isInfSeq TEnv
env Expr
src -> Either Text Exp -> Maybe (Either Text Exp)
forall a. a -> Maybe a
Just (Either Text Exp -> Maybe (Either Text Exp))
-> Either Text Exp -> Maybe (Either Text Exp)
forall a b. (a -> b) -> a -> b
$ do
            fr <- Either Text Integer
-> (Integer -> Either Text Integer)
-> Maybe Integer
-> Either Text Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text Integer
forall a b. a -> Either a b
Left Text
"cryptol: take of an infinite stream needs a literal length.") Integer -> Either Text Integer
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Integer -> Either Text Integer)
-> Maybe Integer -> Either Text Integer
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Integer
tyNat Type
front
            A.cat <$> infPrefix env fr src
      (Text
"@", [Type
_n, Type
_a, Type
_ix], [Expr
src, Expr
i]) | TEnv -> Expr -> Bool
isInfSeq TEnv
env Expr
src -> Either Text Exp -> Maybe (Either Text Exp)
forall a. a -> Maybe a
Just (Either Text Exp -> Maybe (Either Text Exp))
-> Either Text Exp -> Maybe (Either Text Exp)
forall a b. (a -> b) -> a -> b
$ do
            iA <- TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env [] Expr
i
            case litVal iA of
                  Just Integer
j  -> do
                        es <- TEnv -> Integer -> Expr -> Either Text [Exp]
infPrefix TEnv
env (Integer
j Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Expr
src
                        maybe (Left "cryptol: infinite-stream index out of the demanded prefix (rwcry bug).") pure
                              $ lookup j $ zip [0 ..] es
                  Maybe Integer
Nothing -> Text -> Either Text Exp
forall a b. a -> Either a b
Left Text
"cryptol: a variable index into an infinite stream has unbounded demand; use a constant index or take a finite prefix."
      (Text
"!",  [Type]
_, Expr
src : [Expr]
_) | TEnv -> Expr -> Bool
isInfSeq TEnv
env Expr
src -> Either Text Exp -> Maybe (Either Text Exp)
forall a. a -> Maybe a
Just (Either Text Exp -> Maybe (Either Text Exp))
-> Either Text Exp -> Maybe (Either Text Exp)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Exp
forall a b. a -> Either a b
Left Text
"cryptol: an infinite stream cannot be indexed from the end."
      (Text
"drop", [Type]
_, [Expr
src])   | TEnv -> Expr -> Bool
isInfSeq TEnv
env Expr
src -> Either Text Exp -> Maybe (Either Text Exp)
forall a. a -> Maybe a
Just (Either Text Exp -> Maybe (Either Text Exp))
-> Either Text Exp -> Maybe (Either Text Exp)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Exp
forall a b. a -> Either a b
Left Text
"cryptol: drop of an infinite stream is only realizable inside a finite take or index."
      (Text, [Type], [Expr])
_ -> Maybe (Either Text Exp)
forall a. Maybe a
Nothing

-- | The first @k@ elements (each a translated element-width expression)
--   of an infinite -- or, where it bottoms out, finite -- sequence
--   expression. This is the demand-driven realization of the bounded
--   fragment of infinite streams: the four stream shapes (infFrom,
--   infFromThen, and the scanl/comprehension that iterate and repeat
--   desugar to), append with a finite front, drop, and recursive stream
--   definitions.
infPrefix :: TEnv -> Integer -> T.Expr -> Either Text [A.Exp]
infPrefix :: TEnv -> Integer -> Expr -> Either Text [Exp]
infPrefix TEnv
env Integer
k Expr
e
      | Integer
k Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0    = [Exp] -> Either Text [Exp]
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      | Bool
otherwise = case Expr -> (Expr, [Type], [Expr])
spine Expr
e of
            (T.EVar Name
x, [Type]
_, [Expr]
args)
                  | Just (TEnv
envS, Expr
rhs) <- Int -> HashMap Int (TEnv, Expr) -> Maybe (TEnv, Expr)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Name -> Int
N.nameUnique Name
x) (TEnv -> HashMap Int (TEnv, Expr)
teStrms TEnv
env), [Expr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr]
args -> TEnv -> TEnv -> Name -> Expr -> Integer -> Either Text [Exp]
infStream TEnv
env TEnv
envS Name
x Expr
rhs Integer
k
                  | Just (TEnv
envF, Expr
rhs) <- Int -> HashMap Int (TEnv, Expr) -> Maybe (TEnv, Expr)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Name -> Int
N.nameUnique Name
x) (TEnv -> HashMap Int (TEnv, Expr)
teFuns TEnv
env)  -> TEnv -> TEnv -> Expr -> [Expr] -> Either Text (TEnv, Expr)
betaBind TEnv
env TEnv
envF Expr
rhs [Expr]
args Either Text (TEnv, Expr)
-> ((TEnv, Expr) -> Either Text [Exp]) -> Either Text [Exp]
forall a b. Either Text a -> (a -> Either Text b) -> Either Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (TEnv
e', Expr
b) -> TEnv -> Integer -> Expr -> Either Text [Exp]
infPrefix TEnv
e' Integer
k Expr
b
                  | Just (Text
pn, [Type]
ptys) <- Int -> HashMap Int (Text, [Type]) -> Maybe (Text, [Type])
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Name -> Int
N.nameUnique Name
x) (TEnv -> HashMap Int (Text, [Type])
tePrims TEnv
env)  -> TEnv -> Integer -> Text -> [Type] -> [Expr] -> Either Text [Exp]
infPrim TEnv
env Integer
k Text
pn [Type]
ptys [Expr]
args
                  | Bool
otherwise -> Text -> Either Text [Exp]
forall a b. a -> Either a b
Left (Text -> Either Text [Exp]) -> Text -> Either Text [Exp]
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: unsupported infinite-stream source: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ident -> Text
I.identText (Name -> Ident
N.nameIdent Name
x)
            (T.EComp Type
_ Type
_ Expr
body [[Match]]
mss, [Type]
_, []) -> TEnv -> Integer -> Expr -> [[Match]] -> Either Text [Exp]
infComp TEnv
env Integer
k Expr
body [[Match]]
mss
            (Expr
_, [Type]
_, [Expr]
_) | Bool -> Bool
not (TEnv -> Expr -> Bool
isInfSeq TEnv
env Expr
e) -> TEnv -> Integer -> Expr -> Either Text [Exp]
finiteElems TEnv
env Integer
k Expr
e -- a finite tail
            (Expr, [Type], [Expr])
_ -> Text -> Either Text [Exp]
forall a b. a -> Either a b
Left (Text -> Either Text [Exp]) -> Text -> Either Text [Exp]
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: unsupported infinite-stream expression" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr -> Text
unsupported Expr
e

-- | The first @k@ elements of an infinite-stream primitive application.
infPrim :: TEnv -> Integer -> Text -> [T.Type] -> [T.Expr] -> Either Text [A.Exp]
infPrim :: TEnv -> Integer -> Text -> [Type] -> [Expr] -> Either Text [Exp]
infPrim TEnv
env Integer
k Text
pn [Type]
ptys [Expr]
args = case (Text
pn, [Type]
ptys, [Expr]
args) of
      (Text
"infFrom", [Type
a], [Expr
start]) -> do
            we <- Type -> Either Text Integer
tyWidth Type
a
            s  <- transExp env [] start
            pure [ if i == 0 then s else A.Prim noAnn (fromIntegral we) A.Add [s, A.Lit noAnn $ bitVec (fromIntegral we) i] | i <- [0 .. k - 1] ]
      (Text
"infFromThen", [Type
a], [Expr
x, Expr
y]) -> do
            we <- Type -> Either Text Integer
tyWidth Type
a
            xA <- transExp env [] x
            yA <- transExp env [] y
            let w    = Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
we
                step = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
w Op
A.Sub [Exp
yA, Exp
xA]
            pure [ if i == 0 then xA
                   else if i == 1 then yA
                   else A.Prim noAnn w A.Add [xA, A.Prim noAnn w A.Mul [A.Lit noAnn $ bitVec (fromIntegral w) i, step]]
                 | i <- [0 .. k - 1] ]
      (Text
"#", [Type
front, Type
_back, Type
_a], [Expr
l, Expr
r]) -> do
            m <- Either Text Integer
-> (Integer -> Either Text Integer)
-> Maybe Integer
-> Either Text Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text Integer
forall a b. a -> Either a b
Left Text
"cryptol: (#) with a non-literal front length.") Integer -> Either Text Integer
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Integer -> Either Text Integer)
-> Maybe Integer -> Either Text Integer
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Integer
tyNat Type
front
            ls <- finiteElems env (min k m) l
            rs <- if k > m then infPrefix env (k - m) r else pure []
            pure $ take (fromIntegral k) $ ls <> rs
      (Text
"drop", [Type
d, Type
_back, Type
_a], [Expr
src]) -> do
            dv <- Either Text Integer
-> (Integer -> Either Text Integer)
-> Maybe Integer
-> Either Text Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text Integer
forall a b. a -> Either a b
Left Text
"cryptol: drop of an infinite stream needs a literal count.") Integer -> Either Text Integer
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Integer -> Either Text Integer)
-> Maybe Integer -> Either Text Integer
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Integer
tyNat Type
d
            drop (fromIntegral dv) <$> infPrefix env (k + dv) src
      (Text
"take", [Type
front, Type
_back, Type
_a], [Expr
src]) -> do
            fr <- Either Text Integer
-> (Integer -> Either Text Integer)
-> Maybe Integer
-> Either Text Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text Integer
forall a b. a -> Either a b
Left Text
"cryptol: take needs a literal length.") Integer -> Either Text Integer
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Integer -> Either Text Integer)
-> Maybe Integer -> Either Text Integer
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Integer
tyNat Type
front
            take (fromIntegral $ min k fr) <$> infPrefix env (min k fr) src
      (Text
"scanl", [Type
_n, Type
_ta, Type
_tb], [Expr
f, Expr
z, Expr
xs]) -> TEnv -> Integer -> Expr -> Expr -> Expr -> Either Text [Exp]
infScan TEnv
env Integer
k Expr
f Expr
z Expr
xs
      -- zero : [inf]a -- an infinite run of the zero value (the driver
      -- iterate's scanl consumes; usually a() with zero width).
      (Text
"zero", [Type
t], []) -> do
            el <- Either Text Type
-> (Type -> Either Text Type) -> Maybe Type -> Either Text Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text Type
forall a b. a -> Either a b
Left Text
"cryptol: zero at a non-sequence infinite type.") Type -> Either Text Type
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Type -> Either Text Type) -> Maybe Type -> Either Text Type
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Type
seqElemType Type
t
            we <- tyWidth el
            pure $ replicate (fromIntegral k) $ A.Lit noAnn $ zeros $ fromIntegral we
      (Text, [Type], [Expr])
_ -> Text -> Either Text [Exp]
forall a b. a -> Either a b
Left (Text -> Either Text [Exp]) -> Text -> Either Text [Exp]
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: unsupported infinite-stream primitive: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pn

-- | The first @k@ elements of @scanl f z xs@ (the desugaring of
--   @iterate@): the running accumulators z, f z xs0, f (f z xs0) xs1,
--   ... let-bound so a reused accumulator does not duplicate.
infScan :: TEnv -> Integer -> T.Expr -> T.Expr -> T.Expr -> Either Text [A.Exp]
infScan :: TEnv -> Integer -> Expr -> Expr -> Expr -> Either Text [Exp]
infScan TEnv
env Integer
k Expr
f Expr
z Expr
xs = do
      zA  <- TEnv -> [Exp] -> Expr -> Either Text Exp
transExp TEnv
env [] Expr
z
      xse <- if k > 1 then take (fromIntegral k - 1) <$> infPrefix env (k - 1) xs else pure []
      let w    = Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
zA
          nm Integer
i = Text
"iter$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt (TEnv -> Int
teDepth TEnv
env) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. TextShow a => a -> Text
showt (Integer
i :: Integer)
          env' = TEnv
env { teDepth = teDepth env + 1 }
      binds <- goScan env' w nm 0 zA xse
      let refs = Exp
zA Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [ Annote -> Size -> Text -> Exp
A.Var Annote
noAnn Size
w (Integer -> Text
nm Integer
i) | (Integer
i, Exp
_) <- [Integer] -> [Exp] -> [(Integer, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1 ..] [Exp]
xse ]
      -- Wrap each let around the whole list (they nest); the caller cats
      -- or selects, so wrap every element in the accumulated binders.
      pure $ map (wrapLets binds) refs
      where goScan :: TEnv -> A.Size -> (Integer -> A.Name) -> Integer -> A.Exp -> [A.Exp] -> Either Text [(A.Name, A.Exp)]
            goScan :: TEnv
-> Size
-> (Integer -> Text)
-> Integer
-> Exp
-> [Exp]
-> Either Text [(Text, Exp)]
goScan TEnv
_ Size
_ Integer -> Text
_ Integer
_ Exp
_ []           = [(Text, Exp)] -> Either Text [(Text, Exp)]
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            goScan TEnv
e' Size
w Integer -> Text
nm Integer
i Exp
acc (Exp
x : [Exp]
xs') = do
                  body <- TEnv -> Expr -> [Exp] -> Either Text Exp
applyFn TEnv
e' Expr
f [Exp
acc, Exp
x]
                  let nm' = Integer -> Text
nm (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)
                  ((nm', body) :) <$> goScan e' w nm (i + 1) (A.Var noAnn w nm') xs'

            wrapLets :: [(A.Name, A.Exp)] -> A.Exp -> A.Exp
            wrapLets :: [(Text, Exp)] -> Exp -> Exp
wrapLets [(Text, Exp)]
bs Exp
body = ((Text, Exp) -> Exp -> Exp) -> Exp -> [(Text, Exp)] -> Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Text
x, Exp
rhs) Exp
b -> Annote -> Size -> Text -> Exp -> Exp -> Exp
A.Let Annote
noAnn (Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
b) Text
x Exp
rhs Exp
b) Exp
body [(Text, Exp)]
bs

-- | The first @k@ elements of an infinite comprehension. Supported: a
--   single parallel arm of one generator over an infinite (or finite)
--   source, plus @let@ matches -- the shape @repeat@ and simple maps
--   over a stream desugar to. Element j binds the generator variable to
--   element j of its source.
infComp :: TEnv -> Integer -> T.Expr -> [[T.Match]] -> Either Text [A.Exp]
infComp :: TEnv -> Integer -> Expr -> [[Match]] -> Either Text [Exp]
infComp TEnv
env Integer
k Expr
body [[Match]]
mss = case [[Match]]
mss of
      [[Match]
ms] -> do
            gens <- (Match
 -> Either
      Text (Maybe Integer, Integer -> Either Text [(Name, Type, Exp)]))
-> [Match]
-> Either
     Text [(Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Match
-> Either
     Text (Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])
genElems [Match]
ms
            let lens = [ Integer
n | Just Integer
n <- ((Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])
 -> Maybe Integer)
-> [(Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])]
-> [Maybe Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])
-> Maybe Integer
forall a b. (a, b) -> a
fst [(Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])]
gens ]
                kk   = Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ [Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (Integer
k Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: [Integer]
lens)
            mapM (element gens) [0 .. kk - 1]
      [[Match]]
_ -> Text -> Either Text [Exp]
forall a b. a -> Either a b
Left Text
"cryptol: only a single-arm infinite comprehension is supported (parallel/nested infinite comprehensions are not)."
      where -- Each match: its length (Nothing = infinite) and a function
            -- from element index to the bindings it introduces.
            genElems :: T.Match -> Either Text (Maybe Integer, Integer -> Either Text [(N.Name, T.Type, A.Exp)])
            genElems :: Match
-> Either
     Text (Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])
genElems = \ case
                  T.From Name
x Type
_ Type
et Expr
src
                        | TEnv -> Expr -> Bool
isInfSeq TEnv
env Expr
src -> do
                              es <- TEnv -> Integer -> Expr -> Either Text [Exp]
infPrefix TEnv
env Integer
k Expr
src
                              pure (Nothing, \ Integer
j -> Either Text [(Name, Type, Exp)]
-> (Exp -> Either Text [(Name, Type, Exp)])
-> Maybe Exp
-> Either Text [(Name, Type, Exp)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text [(Name, Type, Exp)]
forall a b. a -> Either a b
Left Text
"cryptol: comprehension source too short (rwcry bug).") ([(Name, Type, Exp)] -> Either Text [(Name, Type, Exp)]
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Name, Type, Exp)] -> Either Text [(Name, Type, Exp)])
-> (Exp -> [(Name, Type, Exp)])
-> Exp
-> Either Text [(Name, Type, Exp)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Type, Exp) -> [(Name, Type, Exp)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Name, Type, Exp) -> [(Name, Type, Exp)])
-> (Exp -> (Name, Type, Exp)) -> Exp -> [(Name, Type, Exp)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name
x, Type
et, )) (Maybe Exp -> Either Text [(Name, Type, Exp)])
-> Maybe Exp -> Either Text [(Name, Type, Exp)]
forall a b. (a -> b) -> a -> b
$ Integer -> [(Integer, Exp)] -> Maybe Exp
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Integer
j ([(Integer, Exp)] -> Maybe Exp) -> [(Integer, Exp)] -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ [Integer] -> [Exp] -> [(Integer, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0 ..] [Exp]
es)
                        | Bool
otherwise -> do
                              (n, we) <- Type -> Either Text (Integer, Integer)
seqWidths (Type -> Either Text (Integer, Integer))
-> Type -> Either Text (Integer, Integer)
forall a b. (a -> b) -> a -> b
$ Map Name Schema -> Expr -> Type
T.fastTypeOf (TEnv -> Map Name Schema
teTypes TEnv
env) Expr
src
                              srcA    <- transExp env [] src
                              pure (Just n, \ Integer
j -> [(Name, Type, Exp)] -> Either Text [(Name, Type, Exp)]
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ (Name
x, Type
et, Integer -> Integer -> Integer -> Exp -> Exp
elemSlice Integer
n Integer
we Integer
j Exp
srcA) ])
                  T.Let Decl
_ -> Text
-> Either
     Text (Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])
forall a b. a -> Either a b
Left Text
"cryptol: a let in an infinite comprehension is not supported yet."

            element :: [(Maybe Integer, Integer -> Either Text [(N.Name, T.Type, A.Exp)])] -> Integer -> Either Text A.Exp
            element :: [(Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])]
-> Integer -> Either Text Exp
element [(Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])]
gens Integer
j = do
                  binds <- [[(Name, Type, Exp)]] -> [(Name, Type, Exp)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Name, Type, Exp)]] -> [(Name, Type, Exp)])
-> Either Text [[(Name, Type, Exp)]]
-> Either Text [(Name, Type, Exp)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])
 -> Either Text [(Name, Type, Exp)])
-> [(Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])]
-> Either Text [[(Name, Type, Exp)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (((Integer -> Either Text [(Name, Type, Exp)])
-> Integer -> Either Text [(Name, Type, Exp)]
forall a b. (a -> b) -> a -> b
$ Integer
j) ((Integer -> Either Text [(Name, Type, Exp)])
 -> Either Text [(Name, Type, Exp)])
-> ((Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])
    -> Integer -> Either Text [(Name, Type, Exp)])
-> (Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])
-> Either Text [(Name, Type, Exp)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])
-> Integer -> Either Text [(Name, Type, Exp)]
forall a b. (a, b) -> b
snd) [(Maybe Integer, Integer -> Either Text [(Name, Type, Exp)])]
gens
                  transExp (bindAll env binds) [] body

-- | The first @k@ elements of a recursive infinite-stream definition
--   (@s = front # [ f s ... | ... ]@): unroll element by element, each
--   new element referencing earlier ones through the growing binding of
--   the stream name; the elements are let-bound in order.
infStream :: TEnv -> TEnv -> N.Name -> T.Expr -> Integer -> Either Text [A.Exp]
infStream :: TEnv -> TEnv -> Name -> Expr -> Integer -> Either Text [Exp]
infStream TEnv
_siteEnv TEnv
defEnv Name
sname Expr
rhs Integer
k = do
      elemT <- Either Text Type
-> (Type -> Either Text Type) -> Maybe Type -> Either Text Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text Type
forall a b. a -> Either a b
Left Text
"cryptol: a recursive stream binding is not an infinite sequence (rwcry bug).") Type -> Either Text Type
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (Maybe Type -> Either Text Type) -> Maybe Type -> Either Text Type
forall a b. (a -> b) -> a -> b
$ TEnv -> Expr -> Maybe Type
seqInfElem TEnv
defEnv (Name -> Expr
T.EVar Name
sname)
      we    <- tyWidth elemT
      let nm Integer
i = Text -> Text
sanitize (Ident -> Text
I.identText (Ident -> Text) -> Ident -> Text
forall a b. (a -> b) -> a -> b
$ Name -> Ident
N.nameIdent Name
sname) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt (Name -> Int
N.nameUnique Name
sname) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. TextShow a => a -> Text
showt (Integer
i :: Integer)
          -- The stream name resolves to the concatenation of the
          -- per-element variables computed so far (front-padded), so a
          -- self-reference @s\@(j-d)@ slices out element (j-d).
          bindStream :: Integer -> TEnv
          bindStream Integer
have = TEnv
defEnv { teStrms = HM.delete (N.nameUnique sname) $ teStrms defEnv
                                   , teScope = HM.insert (N.nameUnique sname)
                                          (A.cat [ A.Var noAnn (fromIntegral we) (nm i) | i <- [0 .. have - 1] ]) (teScope defEnv)
                                   , teTypes = Map.insert sname (T.tMono $ T.tSeq (T.tNum have) elemT) (teTypes defEnv) }
      -- Compute elements 0..k-1: element j is the j-th element of the
      -- RHS evaluated with the stream bound to elements 0..j-1 (so any
      -- self-reference must be to an earlier, lagged, element).
      let go :: Integer -> [(A.Name, A.Exp)] -> Either Text [(A.Name, A.Exp)]
          go Integer
j [(Text, Exp)]
acc
                | Integer
j Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
k    = [(Text, Exp)] -> Either Text [(Text, Exp)]
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Text, Exp)] -> Either Text [(Text, Exp)])
-> [(Text, Exp)] -> Either Text [(Text, Exp)]
forall a b. (a -> b) -> a -> b
$ [(Text, Exp)] -> [(Text, Exp)]
forall a. [a] -> [a]
reverse [(Text, Exp)]
acc
                | Bool
otherwise = do
                      es <- TEnv -> Integer -> Expr -> Either Text [Exp]
infPrefix (Integer -> TEnv
bindStream Integer
j) (Integer
j Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Expr
rhs
                      ej <- maybe (Left "cryptol: recursive stream element out of range (rwcry bug).") pure $ lookup j $ zip [0 ..] es
                      go (j + 1) ((nm j, pev ej) : acc)
      binds <- go 0 []
      -- Reject a self-reference that isn't strictly lagged (a cycle):
      -- element j's rhs must reference only earlier element variables.
      let names = [ (Integer -> Text
nm Integer
i, Integer
i) | Integer
i <- [Integer
0 .. Integer
k Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1] ]
      mapM_ (checkLag names) $ zip [0 ..] binds
      let refs = [ Annote -> Size -> Text -> Exp
A.Var Annote
noAnn (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
we) (Integer -> Text
nm Integer
i) | Integer
i <- [Integer
0 .. Integer
k Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1] ]
      pure $ map (\ Exp
r -> ((Text, Exp) -> Exp -> Exp) -> Exp -> [(Text, Exp)] -> Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Text
x, Exp
rhs') Exp
b -> Annote -> Size -> Text -> Exp -> Exp -> Exp
A.Let Annote
noAnn (Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
b) Text
x Exp
rhs' Exp
b) Exp
r [(Text, Exp)]
binds) refs
      where checkLag :: [(A.Name, Integer)] -> (Integer, (A.Name, A.Exp)) -> Either Text ()
            checkLag :: [(Text, Integer)] -> (Integer, (Text, Exp)) -> Either Text ()
checkLag [(Text, Integer)]
names (Integer
j, (Text
_, Exp
ej)) =
                  case [ Integer
i | Text
r <- Exp -> [Text]
varRefs Exp
ej, Just Integer
i <- [Text -> [(Text, Integer)] -> Maybe Integer
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
r [(Text, Integer)]
names], Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
j ] of
                        (Integer
_ : [Integer]
_) -> Text -> Either Text ()
forall a b. a -> Either a b
Left Text
"cryptol: a recursive stream element depends on itself or a later element (an unbounded/ill-founded stream)."
                        []      -> () -> Either Text ()
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | The first @k@ elements of a finite sequence expression (slicing its
--   translation); fewer if the sequence is shorter than @k@.
finiteElems :: TEnv -> Integer -> T.Expr -> Either Text [A.Exp]
finiteElems :: TEnv -> Integer -> Expr -> Either Text [Exp]
finiteElems TEnv
env Integer
k Expr
e = do
      (n, we) <- Type -> Either Text (Integer, Integer)
seqWidths (Type -> Either Text (Integer, Integer))
-> Type -> Either Text (Integer, Integer)
forall a b. (a -> b) -> a -> b
$ Map Name Schema -> Expr -> Type
T.fastTypeOf (TEnv -> Map Name Schema
teTypes TEnv
env) Expr
e
      eA      <- transExp env [] e
      pure [ elemSlice n we i eA | i <- [0 .. min k n - 1] ]

-- | Element @i@ (from the front -- index 0 is the most significant) of a
--   sequence of @n@ elements of width @we@.
elemSlice :: Integer -> Integer -> Integer -> A.Exp -> A.Exp
elemSlice :: Integer -> Integer -> Integer -> Exp -> Exp
elemSlice Integer
n Integer
we Integer
i = Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Size) -> Integer -> Size
forall a b. (a -> b) -> a -> b
$ (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
i) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
we) (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
we)

-- | Resize an expression to a target width: zero-extend if wider,
--   truncate (keeping the low bits) if narrower.
resize :: A.Size -> A.Exp -> A.Exp
resize :: Size -> Exp -> Exp
resize Size
w Exp
e
      | Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
e Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
w = Exp
e
      | Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
e Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<  Size
w = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
w (Size -> Op
A.ZExt Size
w) [Exp
e]
      | Bool
otherwise       = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
w (Size -> Op
A.Trunc Size
w) [Exp
e]

-- | A reference, applied: a primitive instance, a translated definition,
--   or a local.
apply :: TEnv -> N.Name -> [A.Exp] -> Either Text A.Exp
apply :: TEnv -> Name -> [Exp] -> Either Text Exp
apply TEnv
env Name
x [Exp]
args
      | Just (Text
pn, [Type]
tys) <- Int -> HashMap Int (Text, [Type]) -> Maybe (Text, [Type])
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Int
u (HashMap Int (Text, [Type]) -> Maybe (Text, [Type]))
-> HashMap Int (Text, [Type]) -> Maybe (Text, [Type])
forall a b. (a -> b) -> a -> b
$ TEnv -> HashMap Int (Text, [Type])
tePrims TEnv
env = Text -> [Type] -> [Exp] -> Either Text Exp
transPrim Text
pn [Type]
tys [Exp]
args
      | Just (Text
g, A.Sig Annote
_ [Size]
aszs Size
rsz) <- Int -> HashMap Int (Text, Sig) -> Maybe (Text, Sig)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Int
u (HashMap Int (Text, Sig) -> Maybe (Text, Sig))
-> HashMap Int (Text, Sig) -> Maybe (Text, Sig)
forall a b. (a -> b) -> a -> b
$ TEnv -> HashMap Int (Text, Sig)
teDefns TEnv
env =
            if [Exp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Size] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Size]
aszs
                  then Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Text -> [Exp] -> Exp
A.Call Annote
noAnn Size
rsz Text
g [Exp]
args
                  else Text -> Either Text Exp
forall a b. a -> Either a b
Left (Text -> Either Text Exp) -> Text -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: partial application of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ident -> Text
I.identText (Name -> Ident
N.nameIdent Name
x) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" cannot cross the Cryptol boundary."
      | Just (TEnv
envF, Expr
rhs) <- Int -> HashMap Int (TEnv, Expr) -> Maybe (TEnv, Expr)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Int
u (HashMap Int (TEnv, Expr) -> Maybe (TEnv, Expr))
-> HashMap Int (TEnv, Expr) -> Maybe (TEnv, Expr)
forall a b. (a -> b) -> a -> b
$ TEnv -> HashMap Int (TEnv, Expr)
teFuns TEnv
env =
            TEnv -> [Exp] -> Expr -> Either Text Exp
transExp (TEnv
envF { teDepth = teDepth env }) [Exp]
args Expr
rhs
      | Just Exp
v <- Int -> HashMap Int Exp -> Maybe Exp
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Int
u (HashMap Int Exp -> Maybe Exp) -> HashMap Int Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ TEnv -> HashMap Int Exp
teScope TEnv
env =
            if [Exp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Exp]
args
                  then Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
v
                  else Text -> Either Text Exp
forall a b. a -> Either a b
Left (Text -> Either Text Exp) -> Text -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: local " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ident -> Text
I.identText (Name -> Ident
N.nameIdent Name
x) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is used as a function (higher-order locals are not supported)."
      | Bool
otherwise = Text -> Either Text Exp
forall a b. a -> Either a b
Left (Text -> Either Text Exp) -> Text -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: unsupported reference: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ident -> Text
I.identText (Name -> Ident
N.nameIdent Name
x)
      where u :: Int
u = Name -> Int
N.nameUnique Name
x

-- | The primitive table: Cryptol prelude primitives at bitvector-ish
--   instances, mapped per doc/hyle.md section 8.4 (in reverse). @tys@
--   are the primitive's instantiation types, recovered from the
--   specializer's name map.
transPrim :: Text -> [T.Type] -> [A.Exp] -> Either Text A.Exp
transPrim :: Text -> [Type] -> [Exp] -> Either Text Exp
transPrim Text
pn [Type]
tys [Exp]
args = case (Text
pn, [Type]
tys, [Exp]
args) of
      (Text
"number", [Type
v, Type
rep], [])       -> do
            val <- Text -> Type -> Either Text Integer
tyNat' Text
"number" Type
v
            case wordWidth rep of
                  Just Integer
w  -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
w) Integer
val
                  Maybe Integer
Nothing | Type -> Bool
isInteger Type
rep -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Exp
intLit Integer
val
                  Maybe Integer
Nothing | Just Integer
n <- Type -> Maybe Integer
zN Type
rep -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> Natural -> Int
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
nbits (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) (Integer -> BV) -> Integer -> BV
forall a b. (a -> b) -> a -> b
$ Integer
val Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
n
                  Maybe Integer
Nothing -> Text -> Either Text Exp
forall a b. a -> Either a b
Left (Text -> Either Text Exp) -> Text -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: a numeric literal at an unsupported type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
tshow Type
rep
      (Text
"True",  [Type]
_, [])               -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec Int
1 (Integer
1 :: Integer)
      (Text
"False", [Type]
_, [])               -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec Int
1 (Integer
0 :: Integer)
      (Text
"zero", [Type
t], [])              -> Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> (Integer -> BV) -> Integer -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> BV
zeros (Int -> BV) -> (Integer -> Int) -> Integer -> BV
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Exp) -> Either Text Integer -> Either Text Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Either Text Integer
tyWidth Type
t
      -- Z n (integers mod n): a value in @[nbits n]@; Ring operations
      -- reduce modulo n (computed at a width wide enough to hold the
      -- unreduced result). fromInteger reduces a constant; == and the
      -- comparisons work on the representation directly.
      (Text
"+",      [Type -> Maybe Integer
zN -> Just Integer
n], [Exp
a, Exp
b]) -> Integer -> Integer -> Op -> Exp -> Exp -> Either Text Exp
zMod Integer
n (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n)   Op
A.Add Exp
a Exp
b
      (Text
"-",      [Type -> Maybe Integer
zN -> Just Integer
n], [Exp
a, Exp
b]) -> Integer -> Integer -> Op -> Exp -> Exp -> Either Text Exp
zMod Integer
n (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n)   Op
A.Add Exp
a (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Exp -> Exp
zNeg Integer
n Exp
b
      (Text
"*",      [Type -> Maybe Integer
zN -> Just Integer
n], [Exp
a, Exp
b]) -> Integer -> Integer -> Op -> Exp -> Exp -> Either Text Exp
zMod Integer
n (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
n)   Op
A.Mul Exp
a Exp
b
      (Text
"negate", [Type -> Maybe Integer
zN -> Just Integer
n], [Exp
a])    -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Exp -> Exp
zNeg Integer
n Exp
a
      -- Field operations at Z p (Cryptol requires p prime): the inverse
      -- is Fermat's a^(p-2) mod p, square-and-multiply unrolled over the
      -- constant exponent's bits (~2*log p modular multiplies -- big for
      -- large p, so warnUses flags it and the size governor bounds it).
      (Text
"recip", [Type -> Maybe Integer
zN -> Just Integer
n], [Exp
a])     -> Integer -> Exp -> Either Text Exp
zRecip Integer
n Exp
a
      (Text
"/.",    [Type -> Maybe Integer
zN -> Just Integer
n], [Exp
a, Exp
b])  -> Integer -> Exp -> Either Text Exp
zRecip Integer
n Exp
b Either Text Exp -> (Exp -> Either Text Exp) -> Either Text Exp
forall a b. Either Text a -> (a -> Either Text b) -> Either Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Integer -> Integer -> Op -> Exp -> Exp -> Either Text Exp
zMod Integer
n (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
n) Op
A.Mul Exp
a
      (Text
"fromInteger", [Type -> Maybe Integer
zN -> Just Integer
n], [Exp
a]) -> do
            let w :: Size
w = Natural -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Size) -> Natural -> Size
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
nbits (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n
            case Exp -> Maybe Integer
litVal Exp
a of
                  Just Integer
v  -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
w) (Integer -> BV) -> Integer -> BV
forall a b. (a -> b) -> a -> b
$ Integer
v Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
n
                  -- Reduce a representable Integer argument mod n, at a
                  -- width wide enough to hold it before reduction.
                  Maybe Integer
Nothing -> do
                        let ww :: Size
ww = Size -> Size -> Size
forall a. Ord a => a -> a -> a
max (Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
a) Size
w
                            r :: Exp
r  = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
ww Op
A.UMod [Size -> Exp -> Exp
resize Size
ww Exp
a, Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
ww) Integer
n]
                        Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
w (Size -> Op
A.Trunc Size
w) [Exp
r]
      (Text
"fromZ",  [Type
_n], [Exp
a])          -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
a -- Z n -> Integer, value-preserving
      (Text
"toInteger", [Type
_t], [Exp
a])       -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
a -- word -> Integer, value-preserving
      (Text
"+", [Type
t], [Exp
a, Exp
b])             -> Text -> Type -> Op -> Exp -> Exp -> Either Text Exp
wordBin Text
"+" Type
t Op
A.Add Exp
a Exp
b
      (Text
"-", [Type
t], [Exp
a, Exp
b])             -> Text -> Type -> Op -> Exp -> Exp -> Either Text Exp
wordBin Text
"-" Type
t Op
A.Sub Exp
a Exp
b
      (Text
"*", [Type
t], [Exp
a, Exp
b])             -> Text -> Type -> Op -> Exp -> Exp -> Either Text Exp
wordBin Text
"*" Type
t Op
A.Mul Exp
a Exp
b
      (Text
"^^", [Type
t], [Exp
a, Exp
b])            -> Text -> Type -> Op -> Exp -> Exp -> Either Text Exp
wordBin Text
"^^" Type
t Op
A.Pow Exp
a Exp
b
      (Text
"/", [Type
t], [Exp
a, Exp
b])             -> Text -> Type -> Op -> Exp -> Exp -> Either Text Exp
wordBin Text
"/" Type
t Op
A.UDiv Exp
a Exp
b
      (Text
"%", [Type
t], [Exp
a, Exp
b])             -> Text -> Type -> Op -> Exp -> Exp -> Either Text Exp
wordBin Text
"%" Type
t Op
A.UMod Exp
a Exp
b
      (Text
"negate", [Type
t], [Exp
a])           -> do
            w <- Text -> Type -> Either Text Size
likeWord Text
"negate" Type
t
            pure $ A.Prim noAnn w A.Sub [A.Lit noAnn $ zeros $ fromIntegral w, a]
      (Text
"complement", [Type
t], [Exp
a])       -> (\ Size
w -> Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
w Op
A.Not [Exp
a]) (Size -> Exp) -> Either Text Size -> Either Text Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Type -> Either Text Size
likeWord Text
"complement" Type
t
      (Text
"&&", [Type
t], [Exp
a, Exp
b])            -> Text -> Type -> Op -> Exp -> Exp -> Either Text Exp
wordBin Text
"&&" Type
t Op
A.And Exp
a Exp
b
      (Text
"||", [Type
t], [Exp
a, Exp
b])            -> Text -> Type -> Op -> Exp -> Exp -> Either Text Exp
wordBin Text
"||" Type
t Op
A.Or Exp
a Exp
b
      (Text
"^", [Type
t], [Exp
a, Exp
b])             -> Text -> Type -> Op -> Exp -> Exp -> Either Text Exp
wordBin Text
"^" Type
t Op
A.XOr Exp
a Exp
b
      (Text
"==", [Type
t], [Exp
a, Exp
b])            -> Type -> Op -> Exp -> Exp -> Either Text Exp
cmp Type
t Op
A.Eq Exp
a Exp
b
      (Text
"!=", [Type
t], [Exp
a, Exp
b])            -> Type -> Op -> Exp -> Exp -> Either Text Exp
cmp Type
t Op
A.Ne Exp
a Exp
b
      (Text
"<",  [Type
t], [Exp
a, Exp
b])            -> Type -> Op -> Exp -> Exp -> Either Text Exp
cmp Type
t Op
A.ULt Exp
a Exp
b
      (Text
"<=", [Type
t], [Exp
a, Exp
b])            -> Type -> Op -> Exp -> Exp -> Either Text Exp
cmp Type
t Op
A.ULe Exp
a Exp
b
      (Text
">",  [Type
t], [Exp
a, Exp
b])            -> Type -> Op -> Exp -> Exp -> Either Text Exp
cmp Type
t Op
A.UGt Exp
a Exp
b
      (Text
">=", [Type
t], [Exp
a, Exp
b])            -> Type -> Op -> Exp -> Exp -> Either Text Exp
cmp Type
t Op
A.UGe Exp
a Exp
b
      (Text
"<$",  [Type
t], [Exp
a, Exp
b])           -> Type -> Op -> Exp -> Exp -> Either Text Exp
cmp Type
t Op
A.SLt Exp
a Exp
b
      (Text
"<=$", [Type
t], [Exp
a, Exp
b])           -> Type -> Op -> Exp -> Exp -> Either Text Exp
cmp Type
t Op
A.SLe Exp
a Exp
b
      (Text
">$",  [Type
t], [Exp
a, Exp
b])           -> Type -> Op -> Exp -> Exp -> Either Text Exp
cmp Type
t Op
A.SGt Exp
a Exp
b
      (Text
">=$", [Type
t], [Exp
a, Exp
b])           -> Type -> Op -> Exp -> Exp -> Either Text Exp
cmp Type
t Op
A.SGe Exp
a Exp
b
      (Text
"<<",  [Type
n, Type
_ix, Type
el], [Exp
a, Exp
b])  -> Text -> Type -> Type -> Op -> Exp -> Exp -> Either Text Exp
shift Text
"<<" Type
n Type
el Op
A.Shl Exp
a Exp
b
      (Text
">>",  [Type
n, Type
_ix, Type
el], [Exp
a, Exp
b])  -> Text -> Type -> Type -> Op -> Exp -> Exp -> Either Text Exp
shift Text
">>" Type
n Type
el Op
A.LShr Exp
a Exp
b
      (Text
">>$", [Type
n, Type
_ix], [Exp
a, Exp
b])      -> (\ Size
w -> Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
w Op
A.AShr [Exp
a, Exp
b]) (Size -> Exp) -> (Integer -> Size) -> Integer -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Exp) -> Either Text Integer -> Either Text Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Type -> Either Text Integer
tyNat' Text
">>$" Type
n
      (Text
"#", [Type
_f, Type
_b, Type
el], [Exp
a, Exp
b])    -> do
            _ <- Type -> Either Text Integer
tyWidth Type
el -- representable
            pure $ A.cat [a, b]
      (Text
"take", [Type
f, Type
b, Type
el], [Exp
a])      -> do
            (fw, bw, ew) <- (,,) (Integer -> Integer -> Integer -> (Integer, Integer, Integer))
-> Either Text Integer
-> Either Text (Integer -> Integer -> (Integer, Integer, Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Type -> Either Text Integer
tyNat' Text
"take" Type
f Either Text (Integer -> Integer -> (Integer, Integer, Integer))
-> Either Text Integer
-> Either Text (Integer -> (Integer, Integer, Integer))
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Type -> Either Text Integer
tyNat' Text
"take" Type
b Either Text (Integer -> (Integer, Integer, Integer))
-> Either Text Integer -> Either Text (Integer, Integer, Integer)
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Either Text Integer
tyWidth Type
el
            pure $ A.Slice noAnn (fromIntegral $ bw * ew) (fromIntegral $ fw * ew) a
      (Text
"drop", [Type
f, Type
b, Type
el], [Exp
a])      -> do
            (_fw, bw, ew) <- (,,) (Integer -> Integer -> Integer -> (Integer, Integer, Integer))
-> Either Text Integer
-> Either Text (Integer -> Integer -> (Integer, Integer, Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Type -> Either Text Integer
tyNat' Text
"drop" Type
f Either Text (Integer -> Integer -> (Integer, Integer, Integer))
-> Either Text Integer
-> Either Text (Integer -> (Integer, Integer, Integer))
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Type -> Either Text Integer
tyNat' Text
"drop" Type
b Either Text (Integer -> (Integer, Integer, Integer))
-> Either Text Integer -> Either Text (Integer, Integer, Integer)
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Either Text Integer
tyWidth Type
el
            pure $ A.Slice noAnn 0 (fromIntegral $ bw * ew) a
      (Text
"head", [Type
n, Type
el], [Exp
a])         -> do
            (nv, ew) <- (,) (Integer -> Integer -> (Integer, Integer))
-> Either Text Integer
-> Either Text (Integer -> (Integer, Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Type -> Either Text Integer
tyNat' Text
"head" Type
n Either Text (Integer -> (Integer, Integer))
-> Either Text Integer -> Either Text (Integer, Integer)
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Either Text Integer
tyWidth Type
el
            pure $ elemSlice (nv + 1) ew 0 a
      (Text
"last", [Type
n, Type
el], [Exp
a])         -> do
            (_, ew) <- (,) (Integer -> Integer -> (Integer, Integer))
-> Either Text Integer
-> Either Text (Integer -> (Integer, Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Type -> Either Text Integer
tyNat' Text
"last" Type
n Either Text (Integer -> (Integer, Integer))
-> Either Text Integer -> Either Text (Integer, Integer)
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Either Text Integer
tyWidth Type
el
            pure $ A.Slice noAnn 0 (fromIntegral ew) a
      (Text
"tail", [Type
n, Type
el], [Exp
a])         -> do
            (nv, ew) <- (,) (Integer -> Integer -> (Integer, Integer))
-> Either Text Integer
-> Either Text (Integer -> (Integer, Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Type -> Either Text Integer
tyNat' Text
"tail" Type
n Either Text (Integer -> (Integer, Integer))
-> Either Text Integer -> Either Text (Integer, Integer)
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Either Text Integer
tyWidth Type
el
            pure $ A.Slice noAnn 0 (fromIntegral $ nv * ew) a
      (Text
"reverse", [Type
n, Type
el], [Exp
a])      -> do
            (nv, ew) <- (,) (Integer -> Integer -> (Integer, Integer))
-> Either Text Integer
-> Either Text (Integer -> (Integer, Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Type -> Either Text Integer
tyNat' Text
"reverse" Type
n Either Text (Integer -> (Integer, Integer))
-> Either Text Integer -> Either Text (Integer, Integer)
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Either Text Integer
tyWidth Type
el
            pure $ A.cat [ elemSlice nv ew i a | i <- [nv - 1, nv - 2 .. 0] ]
      (Text
"split",   [Type]
_, [Exp
a])            -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
a -- regrouping only: the bits are unchanged
      (Text
"join",    [Type]
_, [Exp
a])            -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
a
      (Text
"splitAt", [Type]
_, [Exp
a])            -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
a -- the result tuple is (front, back) = the same bits
      (Text
"min", [Type
t], [Exp
a, Exp
b])           -> (\ Size
w -> Annote -> Size -> Exp -> Exp -> Exp -> Exp
A.If Annote
noAnn Size
w (Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
1 Op
A.ULt [Exp
a, Exp
b]) Exp
a Exp
b) (Size -> Exp) -> Either Text Size -> Either Text Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Type -> Either Text Size
likeWord Text
"min" Type
t
      (Text
"max", [Type
t], [Exp
a, Exp
b])           -> (\ Size
w -> Annote -> Size -> Exp -> Exp -> Exp -> Exp
A.If Annote
noAnn Size
w (Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
1 Op
A.UGt [Exp
a, Exp
b]) Exp
a Exp
b) (Size -> Exp) -> Either Text Size -> Either Text Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Type -> Either Text Size
likeWord Text
"max" Type
t
      (Text
"sum", [Type
n, Type
el], [Exp
a])          -> Text -> Op -> Type -> Type -> Exp -> Either Text Exp
reduce Text
"sum" Op
A.Add Type
n Type
el Exp
a
      (Text
"product", [Type
n, Type
el], [Exp
a])      -> Text -> Op -> Type -> Type -> Exp -> Either Text Exp
reduce Text
"product" Op
A.Mul Type
n Type
el Exp
a
      (Text
"@", [Type
n, Type
el, Type
_ix], [Exp
a, Exp
i])    -> Text -> Bool -> Type -> Type -> Exp -> Exp -> Either Text Exp
index Text
"@" Bool
True  Type
n Type
el Exp
a Exp
i
      (Text
"!", [Type
n, Type
el, Type
_ix], [Exp
a, Exp
i])    -> Text -> Bool -> Type -> Type -> Exp -> Exp -> Either Text Exp
index Text
"!" Bool
False Type
n Type
el Exp
a Exp
i
      -- Hyle is total: there is no bottom. error/assert/undefined (the
      -- latter two are prelude-defined via error) become a zero "poison"
      -- constant of the result width; reachability is the user's
      -- concern, as in synthesized HDL generally. A static scan
      -- (warnUses) emits a compile-time warning. trace/traceVal are the
      -- identity on their result.
      (Text
"error", [Type
a, Type
_n], [Exp]
_)          -> Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> (Integer -> BV) -> Integer -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> BV
zeros (Int -> BV) -> (Integer -> Int) -> Integer -> BV
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Exp) -> Either Text Integer -> Either Text Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Either Text Integer
tyWidth Type
a
      (Text
"trace", [Type
_n, Type
_a, Type
_b], [Exp
_s, Exp
_v, Exp
r]) -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
r
      (Text
"<<<", [Type
n, Type
_ix, Type
el], [Exp
a, Exp
b])  -> Text -> Bool -> Type -> Type -> Exp -> Exp -> Either Text Exp
rotate Text
"<<<" Bool
True  Type
n Type
el Exp
a Exp
b
      (Text
">>>", [Type
n, Type
_ix, Type
el], [Exp
a, Exp
b])  -> Text -> Bool -> Type -> Type -> Exp -> Exp -> Either Text Exp
rotate Text
">>>" Bool
False Type
n Type
el Exp
a Exp
b
      (Text
"update",    [Type
n, Type
el, Type
_ix], [Exp
xs, Exp
i, Exp
v]) -> Text
-> Bool -> Type -> Type -> Exp -> Exp -> Exp -> Either Text Exp
update' Text
"update"    Bool
True  Type
n Type
el Exp
xs Exp
i Exp
v
      (Text
"updateEnd", [Type
n, Type
el, Type
_ix], [Exp
xs, Exp
i, Exp
v]) -> Text
-> Bool -> Type -> Type -> Exp -> Exp -> Exp -> Either Text Exp
update' Text
"updateEnd" Bool
False Type
n Type
el Exp
xs Exp
i Exp
v
      (Text
"transpose", [Type
r, Type
c, Type
el], [Exp
a]) -> do
            (rv, cv, ew) <- (,,) (Integer -> Integer -> Integer -> (Integer, Integer, Integer))
-> Either Text Integer
-> Either Text (Integer -> Integer -> (Integer, Integer, Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Type -> Either Text Integer
tyNat' Text
"transpose" Type
r Either Text (Integer -> Integer -> (Integer, Integer, Integer))
-> Either Text Integer
-> Either Text (Integer -> (Integer, Integer, Integer))
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Type -> Either Text Integer
tyNat' Text
"transpose" Type
c Either Text (Integer -> (Integer, Integer, Integer))
-> Either Text Integer -> Either Text (Integer, Integer, Integer)
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Either Text Integer
tyWidth Type
el
            pure $ A.cat [ elemSlice (rv * cv) ew (i * cv + j) a | j <- [0 .. cv - 1], i <- [0 .. rv - 1] ]
      (Text
"fromInteger", [Type
t], [Exp
a])      -> do
            w <- Text -> Type -> Either Text Size
likeWord Text
"fromInteger" Type
t
            -- A constant folds to a literal; otherwise resize the
            -- representable Integer argument (e.g. fromZ of a Z n value,
            -- whose representation is the underlying word) to the target
            -- word width -- truncating or zero-extending as Cryptol's
            -- Integer-to-word conversion does.
            case litVal a of
                  Just Integer
v  -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
w) Integer
v
                  Maybe Integer
Nothing -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Size -> Exp -> Exp
resize Size
w Exp
a
      (Text
"lg2", [Type
n], [Exp
a])              -> do
            nv <- Text -> Type -> Either Text Integer
tyNat' Text
"lg2" Type
n
            let w = Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
nv
            pure $ foldr (\ Integer
k Exp
rest -> Annote -> Size -> Exp -> Exp -> Exp -> Exp
A.If Annote
noAnn Size
w (Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
1 Op
A.ULe [Exp
a, Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
w) ((Integer
2 :: Integer) Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
k)])
                                                   (Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
w) Integer
k) Exp
rest)
                         (A.Lit noAnn $ bitVec (fromIntegral w) nv) [0 .. nv - 1]
      (Text
"/$", [Type
n], [Exp
a, Exp
b])            -> Bool -> Type -> Exp -> Exp -> Either Text Exp
signedDivMod Bool
True  Type
n Exp
a Exp
b
      (Text
"%$", [Type
n], [Exp
a, Exp
b])            -> Bool -> Type -> Exp -> Exp -> Either Text Exp
signedDivMod Bool
False Type
n Exp
a Exp
b
      (Text
"pmult", [Type
u, Type
v], [Exp
a, Exp
b])      -> do
            (uv, vv) <- (,) (Integer -> Integer -> (Integer, Integer))
-> Either Text Integer
-> Either Text (Integer -> (Integer, Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Type -> Either Text Integer
tyNat' Text
"pmult" Type
u Either Text (Integer -> (Integer, Integer))
-> Either Text Integer -> Either Text (Integer, Integer)
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Type -> Either Text Integer
tyNat' Text
"pmult" Type
v
            let wa = Integer
uv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1                 -- dividend width
                wr = Integer
uv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
vv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1            -- result width
                -- b's coefficient of x^i, gating a shifted-by-i copy of a.
                term Integer
i = Annote -> Size -> Exp -> Exp -> Exp -> Exp
A.If Annote
noAnn (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
wr) (Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i) Size
1 Exp
b)
                              ([Exp] -> Exp
A.cat ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ [ Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros (Int -> BV) -> Int -> BV
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer
wr Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
wa Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
i | Integer
wr Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
wa Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 ]
                                    [Exp] -> [Exp] -> [Exp]
forall a. Semigroup a => a -> a -> a
<> [Exp
a]
                                    [Exp] -> [Exp] -> [Exp]
forall a. Semigroup a => a -> a -> a
<> [ Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros (Int -> BV) -> Int -> BV
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 ])
                              (Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros (Int -> BV) -> Int -> BV
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
wr)
            pure $ foldr (\ Integer
i Exp
acc -> Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
wr) Op
A.XOr [Integer -> Exp
term Integer
i, Exp
acc])
                         (A.Lit noAnn $ zeros $ fromIntegral wr) [0 .. vv]
      (Text
"pdiv", [Type
_u, Type
_v], [Exp
a, Exp
b])     -> [Exp] -> Exp
A.cat ([Exp] -> Exp)
-> (([Exp], [Exp]) -> [Exp]) -> ([Exp], [Exp]) -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Exp], [Exp]) -> [Exp]
forall a b. (a, b) -> a
fst (([Exp], [Exp]) -> Exp)
-> Either Text ([Exp], [Exp]) -> Either Text Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> Exp -> Either Text ([Exp], [Exp])
pdivmod Exp
a Exp
b
      (Text
"pmod", [Type
_u, Type
v], [Exp
a, Exp
b])      -> do
            vv     <- Text -> Type -> Either Text Integer
tyNat' Text
"pmod" Type
v
            (_, r) <- pdivmod a b
            pure $ A.cat $ [ A.Lit noAnn $ zeros $ fromIntegral $ vv - genericLength r | vv > genericLength r ] <> r
      (Text, [Type], [Exp])
_ | Just ([Integer]
vs, Type
elt) <- Text -> [Type] -> Maybe ([Integer], Type)
enumVals Text
pn [Type]
tys, [Exp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Exp]
args -> do
            ew <- Text -> Type -> Either Text Size
likeWord Text
pn Type
elt
            pure $ A.cat [ A.Lit noAnn $ bitVec (fromIntegral ew) v | v <- vs ]
      (Text, [Type], [Exp])
_                              -> Text -> Either Text Exp
forall a b. a -> Either a b
Left (Text -> Either Text Exp) -> Text -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: unsupported primitive: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pn
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (if [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys then Text
"" else Text
" (at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " ((Type -> Text) -> [Type] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Text
tshow [Type]
tys) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
      where wordBin :: Text -> T.Type -> A.Op -> A.Exp -> A.Exp -> Either Text A.Exp
            wordBin :: Text -> Type -> Op -> Exp -> Exp -> Either Text Exp
wordBin Text
nm Type
t Op
op Exp
a Exp
b = (\ Size
w -> Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
w Op
op [Exp
a, Exp
b]) (Size -> Exp) -> Either Text Size -> Either Text Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Type -> Either Text Size
likeWord Text
nm Type
t

            cmp :: T.Type -> A.Op -> A.Exp -> A.Exp -> Either Text A.Exp
            cmp :: Type -> Op -> Exp -> Exp -> Either Text Exp
cmp Type
t Op
op Exp
a Exp
b
                  -- Constant comparisons fold (also covering constant
                  -- Integer-typed operands, whose literals' widths differ).
                  | Op
op Op -> [Op] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Op
A.Eq, Op
A.Ne, Op
A.ULt, Op
A.ULe, Op
A.UGt, Op
A.UGe]
                  , Just Integer
va <- Exp -> Maybe Integer
litVal Exp
a, Just Integer
vb <- Exp -> Maybe Integer
litVal Exp
b =
                        let r :: Bool
r = case Op
op of
                                    Op
A.Eq  -> Integer
va Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
vb
                                    Op
A.Ne  -> Integer
va Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
vb
                                    Op
A.ULt -> Integer
va Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
vb
                                    Op
A.ULe -> Integer
va Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
vb
                                    Op
A.UGt -> Integer
va Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
vb
                                    Op
_     -> Integer
va Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
vb
                        in Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Int -> BV
forall a. Integral a => Int -> a -> BV
bitVec Int
1 (Int -> BV) -> Int -> BV
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum Bool
r
                  | Bool
otherwise = do
                        _ <- Type -> Either Text Integer
tyWidth Type
t -- representable
                        pure $ A.Prim noAnn 1 op [a, b]

            -- Rotation by a constant is re-wiring; by a variable amount,
            -- the doubled-sequence shift trick: rotate the bits of a#a
            -- by (amount mod n) elements and take the top (<<<) or
            -- bottom (>>>) half.
            rotate :: Text -> Bool -> T.Type -> T.Type -> A.Exp -> A.Exp -> Either Text A.Exp
            rotate :: Text -> Bool -> Type -> Type -> Exp -> Exp -> Either Text Exp
rotate Text
nm Bool
left Type
n Type
el Exp
a Exp
b = do
                  nv <- Text -> Type -> Either Text Integer
tyNat' Text
nm Type
n
                  ew <- tyWidth el
                  let w = Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
a
                  if nv <= 1 then pure a else case litVal b of
                        Just Integer
k -> do
                              let k' :: Integer
k' = (if Bool
left then Integer
k else Integer
nv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
k Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
nv) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
nv
                              Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ if Integer
k' Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 then Exp
a else [Exp] -> Exp
A.cat
                                    [ Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn Size
0 (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Size) -> Integer -> Size
forall a b. (a -> b) -> a -> b
$ (Integer
nv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
k') Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
ew) Exp
a
                                    , Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Size) -> Integer -> Size
forall a b. (a -> b) -> a -> b
$ (Integer
nv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
k') Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
ew) (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Size) -> Integer -> Size
forall a b. (a -> b) -> a -> b
$ Integer
k' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
ew) Exp
a ]
                        Maybe Integer
Nothing -> do
                              let wk :: Natural
wk   = Natural -> Natural -> Natural
forall a. Ord a => a -> a -> a
max (Size -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Size -> Natural) -> Size -> Natural
forall a b. (a -> b) -> a -> b
$ Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
b) (Natural -> Natural
nbits (Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
nv) Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1)
                                  wamt :: Size
wamt = Natural -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Size) -> Natural -> Size
forall a b. (a -> b) -> a -> b
$ Natural -> Natural -> Natural
forall a. Ord a => a -> a -> a
max Natural
wk (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
nbits (Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Natural) -> Integer -> Natural
forall a b. (a -> b) -> a -> b
$ (Integer
nv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
ew) Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1
                                  b' :: Exp
b'   | Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
b Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
wamt = Exp
b
                                       | Bool
otherwise          = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
wamt (Size -> Op
A.ZExt Size
wamt) [Exp
b]
                                  kmod :: Exp
kmod = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
wamt Op
A.UMod [Exp
b', Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
wamt) Integer
nv]
                                  amt :: Exp
amt  = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
wamt Op
A.Mul [Exp
kmod, Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
wamt) Integer
ew]
                                  dbl :: Exp
dbl  = Annote -> Exp -> Exp -> Exp
A.Cat Annote
noAnn Exp
a Exp
a
                              Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ if Bool
left
                                    then Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn Size
w Size
w (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn (Size
2 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
w) Op
A.Shl  [Exp
dbl, Exp
amt]
                                    else Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn Size
0 Size
w (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn (Size
2 Size -> Size -> Size
forall a. Num a => a -> a -> a
* Size
w) Op
A.LShr [Exp
dbl, Exp
amt]

            -- Sequence update: a constant index is re-wiring; a variable
            -- index muxes each element against an index comparison.
            update' :: Text -> Bool -> T.Type -> T.Type -> A.Exp -> A.Exp -> A.Exp -> Either Text A.Exp
            update' :: Text
-> Bool -> Type -> Type -> Exp -> Exp -> Exp -> Either Text Exp
update' Text
nm Bool
fromFront Type
n Type
el Exp
xs Exp
i Exp
v = do
                  nv <- Text -> Type -> Either Text Integer
tyNat' Text
nm Type
n
                  ew <- tyWidth el
                  case litVal i of
                        Just Integer
iv -> do
                              Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Integer
iv Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 Bool -> Bool -> Bool
&& Integer
iv Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
nv) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") index out of bounds."
                              let idx :: Integer
idx = if Bool
fromFront then Integer
iv else Integer
nv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
iv -- position from the front (MSB)
                                  off :: Integer
off = (Integer
nv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
idx) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
ew                   -- the replaced element's LSB offset
                              Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
A.cat ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ [ Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Size) -> Integer -> Size
forall a b. (a -> b) -> a -> b
$ Integer
off Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
ew) (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Size) -> Integer -> Size
forall a b. (a -> b) -> a -> b
$ Integer
idx Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
ew) Exp
xs | Integer
idx Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 ]
                                          [Exp] -> [Exp] -> [Exp]
forall a. Semigroup a => a -> a -> a
<> [ Exp
v ]
                                          [Exp] -> [Exp] -> [Exp]
forall a. Semigroup a => a -> a -> a
<> [ Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn Size
0 (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
off) Exp
xs | Integer
off Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 ]
                        Maybe Integer
Nothing -> do
                              let wI :: Size
wI = Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
i
                                  jlit :: Integer -> Maybe Exp
jlit Integer
j = let jv :: Integer
jv = if Bool
fromFront then Integer
j else Integer
nv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
j
                                           in if Integer
jv Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Size -> Integer
forall a. Integral a => a -> Integer
toInteger Size
wI
                                                 then Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
wI) Integer
jv
                                                 else Maybe Exp
forall a. Maybe a
Nothing -- the index can never name this element
                                  elem' :: Integer -> Exp
elem' Integer
j = Integer -> Integer -> Integer -> Exp -> Exp
elemSlice Integer
nv Integer
ew Integer
j Exp
xs
                              Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
A.cat [ case Integer -> Maybe Exp
jlit Integer
j of
                                                 Just Exp
jl -> Annote -> Size -> Exp -> Exp -> Exp -> Exp
A.If Annote
noAnn (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
ew) (Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
1 Op
A.Eq [Exp
i, Exp
jl]) Exp
v (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Exp
elem' Integer
j
                                                 Maybe Exp
Nothing -> Integer -> Exp
elem' Integer
j
                                           | Integer
j <- [Integer
0 .. Integer
nv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1] ]

            -- Signed division/remainder (truncated toward zero, remainder
            -- taking the dividend's sign), via unsigned ops on magnitudes.
            signedDivMod :: Bool -> T.Type -> A.Exp -> A.Exp -> Either Text A.Exp
            signedDivMod :: Bool -> Type -> Exp -> Exp -> Either Text Exp
signedDivMod Bool
isDiv Type
n Exp
a Exp
b = do
                  nv <- Text -> Type -> Either Text Integer
tyNat' (if Bool
isDiv then Text
"/$" else Text
"%$") Type
n
                  let w     = Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
nv
                      z     = Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros (Int -> BV) -> Int -> BV
forall a b. (a -> b) -> a -> b
$ Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
w
                      neg Exp
x = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
w Op
A.Sub [Exp
z, Exp
x]
                      sgn Exp
x = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
1 Op
A.SLt [Exp
x, Exp
z]
                      mag Exp
x = Annote -> Size -> Exp -> Exp -> Exp -> Exp
A.If Annote
noAnn Size
w (Exp -> Exp
sgn Exp
x) (Exp -> Exp
neg Exp
x) Exp
x
                      q     = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
w (if Bool
isDiv then Op
A.UDiv else Op
A.UMod) [Exp -> Exp
mag Exp
a, Exp -> Exp
mag Exp
b]
                  pure $ if isDiv
                        then A.If noAnn w (A.Prim noAnn 1 A.XOr [sgn a, sgn b]) (neg q) q
                        else A.If noAnn w (sgn a) (neg q) q

            -- Polynomial (carry-less) long division by a constant
            -- divisor: quotient and remainder bits as XOR combinations of
            -- the dividend's bits (both MSB-first).
            pdivmod :: A.Exp -> A.Exp -> Either Text ([A.Exp], [A.Exp])
            pdivmod :: Exp -> Exp -> Either Text ([Exp], [Exp])
pdivmod Exp
a Exp
b = do
                  bv <- Either Text Integer
-> (Integer -> Either Text Integer)
-> Maybe Integer
-> Either Text Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text Integer
forall a b. a -> Either a b
Left Text
"cryptol: polynomial division by a non-constant divisor is not supported (pdiv/pmod need a constant polynomial).") Integer -> Either Text Integer
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Integer -> Either Text Integer)
-> Maybe Integer -> Either Text Integer
forall a b. (a -> b) -> a -> b
$ Exp -> Maybe Integer
litVal Exp
b
                  unless (bv /= 0) $ Left "cryptol: polynomial division by zero."
                  let d    = [Integer] -> Integer
forall i a. Num i => [a] -> i
genericLength ((Integer -> Bool) -> [Integer] -> [Integer]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
1) ([Integer] -> [Integer]) -> [Integer] -> [Integer]
forall a b. (a -> b) -> a -> b
$ (Integer -> Integer) -> Integer -> [Integer]
forall a. (a -> a) -> a -> [a]
iterate (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2) Integer
bv) :: Integer
                      wa   = Size -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
a) :: Integer
                      abit Integer
k = Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Size) -> Integer -> Size
forall a b. (a -> b) -> a -> b
$ Integer
wa Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
k) Size
1 Exp
a
                      xor1 Exp
x Exp
y = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
1 Op
A.XOr [Exp
x, Exp
y]
                      step ([Exp]
qs, [Exp]
r) Integer
k =
                            let (Exp
top, [Exp]
rest) = case [Exp]
r [Exp] -> [Exp] -> [Exp]
forall a. Semigroup a => a -> a -> a
<> [Integer -> Exp
abit Integer
k] of -- coefficients x^d .. x^0
                                    Exp
t : [Exp]
r' -> (Exp
t, [Exp]
r')
                                    []     -> (Integer -> Exp
abit Integer
k, [])          -- unreachable: the list is nonempty
                                r2 :: [Exp]
r2  = [ if Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Integer
bv (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer
d Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
j) then Exp -> Exp -> Exp
xor1 Exp
rj Exp
top else Exp
rj
                                      | (Integer
j, Exp
rj) <- [Integer] -> [Exp] -> [(Integer, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0 :: Integer ..] [Exp]
rest ]
                            in ([Exp]
qs [Exp] -> [Exp] -> [Exp]
forall a. Semigroup a => a -> a -> a
<> [Exp
top], [Exp]
r2)
                      (q, r) = foldl step ([], replicate (fromIntegral d) (A.Lit noAnn $ zeros 1)) [0 .. wa - 1]
                  pure (q, r)

            -- Sequence shifts move whole elements (bit shifts when the
            -- elements are bits): the amount scales by the element width.
            shift :: Text -> T.Type -> T.Type -> A.Op -> A.Exp -> A.Exp -> Either Text A.Exp
            shift :: Text -> Type -> Type -> Op -> Exp -> Exp -> Either Text Exp
shift Text
_nm Type
_n Type
el Op
op Exp
a Exp
b = do
                  ew <- Type -> Either Text Integer
tyWidth Type
el
                  let w = Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
a
                  if ew == 1 then pure $ A.Prim noAnn w op [a, b] else case litVal b of
                        Just Integer
k  -> Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
w Op
op [Exp
a, Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Int) -> Natural -> Int
forall a b. (a -> b) -> a -> b
$ Natural -> Natural -> Natural
forall a. Ord a => a -> a -> a
max Natural
1 (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
nbits (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Natural) -> Integer -> Natural
forall a b. (a -> b) -> a -> b
$ Integer
k Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
ew Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) (Integer -> BV) -> Integer -> BV
forall a b. (a -> b) -> a -> b
$ Integer
k Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
ew]
                        Maybe Integer
Nothing -> do
                              -- Wide enough that the element-to-bit scaling can't wrap.
                              let wamt :: Size
wamt = Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
b Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Natural -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Natural -> Natural
forall a. Ord a => a -> a -> a
max Natural
1 (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
nbits (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Natural) -> Integer -> Natural
forall a b. (a -> b) -> a -> b
$ Integer
ew Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)
                                  b' :: Exp
b'   = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
wamt (Size -> Op
A.ZExt Size
wamt) [Exp
b]
                              Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
w Op
op [Exp
a, Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
wamt Op
A.Mul [Exp
b', Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
wamt) Integer
ew]]

            -- Element selection from the front (@) or back (!): a static
            -- slice for a constant index; for a variable index, a shift
            -- by index-times-element-width (toward the MSB end for @,
            -- since element 0 is most significant) and a fixed slice.
            index :: Text -> Bool -> T.Type -> T.Type -> A.Exp -> A.Exp -> Either Text A.Exp
            index :: Text -> Bool -> Type -> Type -> Exp -> Exp -> Either Text Exp
index Text
nm Bool
fromFront Type
n Type
el Exp
a Exp
i = do
                  nv <- Text -> Type -> Either Text Integer
tyNat' Text
nm Type
n
                  ew <- tyWidth el
                  case i of
                        A.Lit Annote
_ BV
bv -> do
                              let iv :: Integer
iv = BV -> Integer
nat BV
bv
                              Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Integer
iv Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 Bool -> Bool -> Bool
&& Integer
iv Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
nv) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") index out of bounds."
                              Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ if Bool
fromFront then Integer -> Integer -> Integer -> Exp -> Exp
elemSlice Integer
nv Integer
ew Integer
iv Exp
a
                                                  else Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Size) -> Integer -> Size
forall a b. (a -> b) -> a -> b
$ Integer
iv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
ew) (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
ew) Exp
a
                        Exp
_ -> do
                              let wAmt :: Size
wAmt = Size -> Size -> Size
forall a. Ord a => a -> a -> a
max Size
1 (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ Natural -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Size) -> Natural -> Size
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
nbits (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Natural) -> Integer -> Natural
forall a b. (a -> b) -> a -> b
$ (Integer
nv Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
ew Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
                                  w :: Size
w    = Size -> Size -> Size
forall a. Ord a => a -> a -> a
max Size
wAmt (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
i
                                  i' :: Exp
i'   | Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
i Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
w = Exp
i
                                       | Bool
otherwise       = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
w (Size -> Op
A.ZExt Size
w) [Exp
i]
                                  amt :: Exp
amt  = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
w Op
A.Mul [Exp
i', Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
w) Integer
ew]
                                  aw :: Size
aw   = Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
a
                              Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ if Bool
fromFront
                                    then Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn (Size
aw Size -> Size -> Size
forall a. Num a => a -> a -> a
- Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
ew) (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
ew) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
aw Op
A.Shl [Exp
a, Exp
amt]
                                    else Annote -> Size -> Size -> Exp -> Exp
A.Slice Annote
noAnn Size
0 (Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
ew) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
aw Op
A.LShr [Exp
a, Exp
amt]

            -- Elementwise reduction of a sequence to one element.
            reduce :: Text -> A.Op -> T.Type -> T.Type -> A.Exp -> Either Text A.Exp
            reduce :: Text -> Op -> Type -> Type -> Exp -> Either Text Exp
reduce Text
nm Op
op Type
n Type
el Exp
a = do
                  nv <- Text -> Type -> Either Text Integer
tyNat' Text
nm Type
n
                  ew <- likeWord nm el
                  let z = Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros (Int -> BV) -> Int -> BV
forall a b. (a -> b) -> a -> b
$ Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
ew
                      zsum | Op
op Op -> Op -> Bool
forall a. Eq a => a -> a -> Bool
== Op
A.Mul = Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
ew) (Integer
1 :: Integer)
                           | Bool
otherwise   = Exp
z
                  pure $ foldl (\ Exp
acc Integer
i -> Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
ew Op
op [Exp
acc, Integer -> Integer -> Integer -> Exp -> Exp
elemSlice Integer
nv (Size -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
ew) Integer
i Exp
a]) zsum [0 .. nv - 1]

            -- A word (or Bit) instance width.
            likeWord :: Text -> T.Type -> Either Text A.Size
            likeWord :: Text -> Type -> Either Text Size
likeWord Text
nm Type
t = case Type -> Maybe Integer
wordWidth Type
t of
                  Just Integer
w  -> Size -> Either Text Size
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Size -> Either Text Size) -> Size -> Either Text Size
forall a b. (a -> b) -> a -> b
$ Integer -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
w
                  Maybe Integer
Nothing -> Text -> Either Text Size
forall a b. a -> Either a b
Left (Text -> Either Text Size) -> Text -> Either Text Size
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") at an unsupported instance type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
tshow Type
t

            tyNat' :: Text -> T.Type -> Either Text Integer
            tyNat' :: Text -> Type -> Either Text Integer
tyNat' Text
nm Type
t = Either Text Integer
-> (Integer -> Either Text Integer)
-> Maybe Integer
-> Either Text Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text Integer
forall a b. a -> Either a b
Left (Text -> Either Text Integer) -> Text -> Either Text Integer
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"): expected a numeric type, got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
tshow Type
t) Integer -> Either Text Integer
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Integer -> Either Text Integer)
-> Maybe Integer -> Either Text Integer
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Integer
tyNat Type
t

            -- Modular reduction of a binary Ring op on Z n: widen the
            -- operands, apply the op at the wider width @cap@ (a bound on
            -- the unreduced result), reduce modulo n, and narrow back.
            zMod :: Integer -> Integer -> A.Op -> A.Exp -> A.Exp -> Either Text A.Exp
            zMod :: Integer -> Integer -> Op -> Exp -> Exp -> Either Text Exp
zMod Integer
n Integer
cap Op
op Exp
a Exp
b = do
                  let w :: Size
w  = Natural -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Size) -> Natural -> Size
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
nbits (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n
                      ww :: Size
ww = Natural -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Size) -> Natural -> Size
forall a b. (a -> b) -> a -> b
$ Natural -> Natural -> Natural
forall a. Ord a => a -> a -> a
max (Size -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
w) (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
nbits (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
cap
                      up :: Exp -> Exp
up Exp
x = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
ww (Size -> Op
A.ZExt Size
ww) [Exp
x]
                      r :: Exp
r  = Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
ww Op
A.UMod [Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
ww Op
op [Exp -> Exp
up Exp
a, Exp -> Exp
up Exp
b], Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
ww) Integer
n]
                  Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Either Text Exp) -> Exp -> Either Text Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
w (Size -> Op
A.Trunc Size
w) [Exp
r]

            -- Negation in Z n: n - a for a /= 0, else 0 (n - a mod n).
            zNeg :: Integer -> A.Exp -> A.Exp
            zNeg :: Integer -> Exp -> Exp
zNeg Integer
n Exp
a = let w :: Size
w = Natural -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Size) -> Natural -> Size
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
nbits (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n
                       in Annote -> Size -> Exp -> Exp -> Exp -> Exp
A.If Annote
noAnn Size
w (Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
1 Op
A.Eq [Exp
a, Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> BV
zeros (Int -> BV) -> Int -> BV
forall a b. (a -> b) -> a -> b
$ Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
w]) Exp
a
                              (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Annote -> Size -> Op -> [Exp] -> Exp
A.Prim Annote
noAnn Size
w Op
A.Sub [Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
w) Integer
n, Exp
a]

            -- The multiplicative inverse in Z p (p prime), a^(p-2) mod p
            -- by square-and-multiply over the constant exponent's bits.
            -- The successive squares are let-bound (each is reused by the
            -- next square and, when the bit is set, by the product);
            -- the product chain threads as an expression (single-use).
            zRecip :: Integer -> A.Exp -> Either Text A.Exp
            zRecip :: Integer -> Exp -> Either Text Exp
zRecip Integer
n Exp
a = do
                  let w :: Size
w    = Natural -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Size) -> Natural -> Size
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
nbits (Natural -> Natural) -> Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n
                      e :: Integer
e    = Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
2                            -- p >= 3, so e >= 1
                      top :: Integer
top  = Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Integer) -> Natural -> Integer
forall a b. (a -> b) -> a -> b
$ Natural -> Natural
nbits (Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1 :: Integer -- >= highest set bit of p-2
                      one :: Exp
one  = Annote -> BV -> Exp
A.Lit Annote
noAnn (BV -> Exp) -> BV -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Integer -> BV
forall a. Integral a => Int -> a -> BV
bitVec (Size -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
w) (Integer
1 :: Integer)
                      bn :: Integer -> Text
bn Integer
i = Text
"zr$b$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall a. TextShow a => a -> Text
showt (Integer
i :: Integer)
                      bvar :: Integer -> Exp
bvar Integer
i = Annote -> Size -> Text -> Exp
A.Var Annote
noAnn Size
w (Text -> Exp) -> Text -> Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Text
bn Integer
i
                  -- base_0 = a, base_{i+1} = base_i^2 (mod p).
                  sqs   <- (Integer -> Either Text (Text, Exp))
-> [Integer] -> Either Text [(Text, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ Integer
i -> (Integer -> Text
bn (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1), ) (Exp -> (Text, Exp)) -> Either Text Exp -> Either Text (Text, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Op -> Exp -> Exp -> Either Text Exp
zMod Integer
n (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
n) Op
A.Mul (Integer -> Exp
bvar Integer
i) (Integer -> Exp
bvar Integer
i)) [Integer
0 .. Integer
top Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1]
                  let lets = (Integer -> Text
bn Integer
0, Exp
a) (Text, Exp) -> [(Text, Exp)] -> [(Text, Exp)]
forall a. a -> [a] -> [a]
: [(Text, Exp)]
sqs
                  -- product of base_i for each set bit i of the exponent.
                  result <- foldM (\ Exp
acc Integer
i -> if Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Integer
e (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
                                                    then Integer -> Integer -> Op -> Exp -> Exp -> Either Text Exp
zMod Integer
n (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
n) Op
A.Mul Exp
acc (Integer -> Exp
bvar Integer
i)
                                                    else Exp -> Either Text Exp
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
acc)
                                  one [0 .. top]
                  pure $ foldr (\ (Text
x, Exp
rhs) Exp
b -> Annote -> Size -> Text -> Exp -> Exp -> Exp
A.Let Annote
noAnn (Exp -> Size
forall a. SizeAnnotated a => a -> Size
A.sizeOf Exp
b) Text
x Exp
rhs Exp
b) result lets


---
--- Cryptol types to widths.
---

-- | The width of a representable Cryptol value type: Bit, words,
--   sequences, tuples, records, and nominal types (newtypes are their
--   field record; enums are nbits(#constructors) of tag plus the widest
--   constructor payload).
tyWidth :: T.Type -> Either Text Integer
tyWidth :: Type -> Either Text Integer
tyWidth Type
t = case Type -> Type
T.tNoUser Type
t of
      T.TCon (T.TC TC
T.TCBit) []      -> Integer -> Either Text Integer
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
1
      T.TCon (T.TC TC
T.TCSeq) [Type
n, Type
el] -> Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*) (Integer -> Integer -> Integer)
-> Either Text Integer -> Either Text (Integer -> Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text Integer
-> (Integer -> Either Text Integer)
-> Maybe Integer
-> Either Text Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text Integer
forall a b. a -> Either a b
Left (Text -> Either Text Integer) -> Text -> Either Text Integer
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: sequence length is not a literal: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
tshow Type
n) Integer -> Either Text Integer
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Maybe Integer
tyNat Type
n)
                                           Either Text (Integer -> Integer)
-> Either Text Integer -> Either Text Integer
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Either Text Integer
tyWidth Type
el
      T.TCon (T.TC (T.TCTuple Int
_)) [Type]
es -> [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Integer] -> Integer)
-> Either Text [Integer] -> Either Text Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Either Text Integer) -> [Type] -> Either Text [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Either Text Integer
tyWidth [Type]
es
      T.TCon (T.TC TC
T.TCIntMod) [Type
n] -> Either Text Integer
-> (Integer -> Either Text Integer)
-> Maybe Integer
-> Either Text Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text Integer
forall a b. a -> Either a b
Left (Text -> Either Text Integer) -> Text -> Either Text Integer
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: Z at a non-literal modulus: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
tshow Type
n)
                                            (Integer -> Either Text Integer
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Either Text Integer)
-> (Integer -> Integer) -> Integer -> Either Text Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Integer) -> (Integer -> Natural) -> Integer -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Natural
nbits (Natural -> Natural) -> (Integer -> Natural) -> Integer -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Type -> Maybe Integer
tyNat Type
n)
      T.TRec RecordMap Ident Type
fs                     -> [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Integer] -> Integer)
-> Either Text [Integer] -> Either Text Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Either Text Integer) -> [Type] -> Either Text [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Either Text Integer
tyWidth (RecordMap Ident Type -> [Type]
forall a b. RecordMap a b -> [b]
recordElements RecordMap Ident Type
fs)
      T.TNominal NominalType
nt [Type]
tys             -> do
            su <- NominalType -> [Type] -> Either Text Subst
paramSubst NominalType
nt [Type]
tys
            case T.ntDef nt of
                  T.Struct StructCon
sc -> [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Integer] -> Integer)
-> Either Text [Integer] -> Either Text Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Either Text Integer) -> [Type] -> Either Text [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Type -> Either Text Integer
tyWidth (Type -> Either Text Integer)
-> (Type -> Type) -> Type -> Either Text Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subst -> Type -> Type
forall t. TVars t => Subst -> t -> t
TS.apSubst Subst
su) (RecordMap Ident Type -> [Type]
forall a b. RecordMap a b -> [b]
recordElements (RecordMap Ident Type -> [Type]) -> RecordMap Ident Type -> [Type]
forall a b. (a -> b) -> a -> b
$ StructCon -> RecordMap Ident Type
T.ntFields StructCon
sc)
                  T.Enum [EnumCon]
ecs  -> do
                        ws <- (EnumCon -> Either Text Integer)
-> [EnumCon] -> Either Text [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([Integer] -> Integer)
-> Either Text [Integer] -> Either Text Integer
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (Either Text [Integer] -> Either Text Integer)
-> (EnumCon -> Either Text [Integer])
-> EnumCon
-> Either Text Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Either Text Integer) -> [Type] -> Either Text [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Type -> Either Text Integer
tyWidth (Type -> Either Text Integer)
-> (Type -> Type) -> Type -> Either Text Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subst -> Type -> Type
forall t. TVars t => Subst -> t -> t
TS.apSubst Subst
su) ([Type] -> Either Text [Integer])
-> (EnumCon -> [Type]) -> EnumCon -> Either Text [Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumCon -> [Type]
T.ecFields) [EnumCon]
ecs
                        pure $ toInteger (nbits $ fromIntegral $ length ecs) + maximum (0 : ws)
                  NominalTypeDef
T.Abstract  -> Text -> Either Text Integer
forall a b. a -> Either a b
Left (Text -> Either Text Integer) -> Text -> Either Text Integer
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: abstract type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
tshow Type
t
      Type
_                             -> Text -> Either Text Integer
forall a b. a -> Either a b
Left (Text -> Either Text Integer) -> Text -> Either Text Integer
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: unrepresentable type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
tshow Type
t

-- | Record fields and widths, in canonical (label-sorted) order -- the
--   layout order, first field most significant. Newtypes are their
--   underlying record.
recFields :: T.Type -> Either Text [(I.Ident, Integer)]
recFields :: Type -> Either Text [(Ident, Integer)]
recFields Type
t = case Type -> Type
T.tNoUser Type
t of
      T.TRec RecordMap Ident Type
fs -> ((Ident, Type) -> Either Text (Ident, Integer))
-> [(Ident, Type)] -> Either Text [(Ident, Integer)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ (Ident
f, Type
ft) -> (Ident
f, ) (Integer -> (Ident, Integer))
-> Either Text Integer -> Either Text (Ident, Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Either Text Integer
tyWidth Type
ft) ([(Ident, Type)] -> Either Text [(Ident, Integer)])
-> [(Ident, Type)] -> Either Text [(Ident, Integer)]
forall a b. (a -> b) -> a -> b
$ RecordMap Ident Type -> [(Ident, Type)]
forall a b. RecordMap a b -> [(a, b)]
canonicalFields RecordMap Ident Type
fs
      T.TNominal NominalType
nt [Type]
tys | T.Struct StructCon
sc <- NominalType -> NominalTypeDef
T.ntDef NominalType
nt -> do
            su <- NominalType -> [Type] -> Either Text Subst
paramSubst NominalType
nt [Type]
tys
            mapM (\ (Ident
f, Type
ft) -> (Ident
f, ) (Integer -> (Ident, Integer))
-> Either Text Integer -> Either Text (Ident, Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Either Text Integer
tyWidth (Subst -> Type -> Type
forall t. TVars t => Subst -> t -> t
TS.apSubst Subst
su Type
ft)) $ canonicalFields $ T.ntFields sc
      Type
_         -> Text -> Either Text [(Ident, Integer)]
forall a b. a -> Either a b
Left (Text -> Either Text [(Ident, Integer)])
-> Text -> Either Text [(Ident, Integer)]
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: expected a record type, got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
tshow Type
t

-- | The substitution instantiating a nominal type's parameters.
paramSubst :: T.NominalType -> [T.Type] -> Either Text TS.Subst
paramSubst :: NominalType -> [Type] -> Either Text Subst
paramSubst NominalType
nt [Type]
tys = do
      Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([TParam] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (NominalType -> [TParam]
T.ntParams NominalType
nt) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys)
            (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: under-applied nominal type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ident -> Text
I.identText (Name -> Ident
N.nameIdent (Name -> Ident) -> Name -> Ident
forall a b. (a -> b) -> a -> b
$ NominalType -> Name
T.ntName NominalType
nt)
      Subst -> Either Text Subst
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Subst -> Either Text Subst) -> Subst -> Either Text Subst
forall a b. (a -> b) -> a -> b
$ [(TParam, Type)] -> Subst
TS.listParamSubst ([(TParam, Type)] -> Subst) -> [(TParam, Type)] -> Subst
forall a b. (a -> b) -> a -> b
$ [TParam] -> [Type] -> [(TParam, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip (NominalType -> [TParam]
T.ntParams NominalType
nt) [Type]
tys

-- | Tuple component widths.
tupleWidths :: T.Type -> Either Text [Integer]
tupleWidths :: Type -> Either Text [Integer]
tupleWidths Type
t = case Type -> Type
T.tNoUser Type
t of
      T.TCon (T.TC (T.TCTuple Int
_)) [Type]
es -> (Type -> Either Text Integer) -> [Type] -> Either Text [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Either Text Integer
tyWidth [Type]
es
      Type
_                              -> Text -> Either Text [Integer]
forall a b. a -> Either a b
Left (Text -> Either Text [Integer]) -> Text -> Either Text [Integer]
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: expected a tuple type, got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
tshow Type
t

-- | Sequence length and element width.
seqWidths :: T.Type -> Either Text (Integer, Integer)
seqWidths :: Type -> Either Text (Integer, Integer)
seqWidths Type
t = case Type -> Type
T.tNoUser Type
t of
      T.TCon (T.TC TC
T.TCSeq) [Type
n, Type
el] -> (,) (Integer -> Integer -> (Integer, Integer))
-> Either Text Integer
-> Either Text (Integer -> (Integer, Integer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text Integer
-> (Integer -> Either Text Integer)
-> Maybe Integer
-> Either Text Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text Integer
forall a b. a -> Either a b
Left Text
"cryptol: sequence length is not a literal.") Integer -> Either Text Integer
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Maybe Integer
tyNat Type
n)
                                           Either Text (Integer -> (Integer, Integer))
-> Either Text Integer -> Either Text (Integer, Integer)
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Either Text Integer
tyWidth Type
el
      Type
_                             -> Text -> Either Text (Integer, Integer)
forall a b. a -> Either a b
Left (Text -> Either Text (Integer, Integer))
-> Text -> Either Text (Integer, Integer)
forall a b. (a -> b) -> a -> b
$ Text
"cryptol: expected a sequence type, got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
tshow Type
t

-- | A word type's width: @[n]@ is @Just n@, @Bit@ is @Just 1@.
wordWidth :: T.Type -> Maybe Integer
wordWidth :: Type -> Maybe Integer
wordWidth Type
t = case Type -> Type
T.tNoUser Type
t of
      T.TCon (T.TC TC
T.TCBit) []      -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
1
      T.TCon (T.TC TC
T.TCSeq) [Type
n, Type
el] | Just Integer
1 <- Type -> Maybe Integer
wordWidth Type
el -> Type -> Maybe Integer
tyNat Type
n
      Type
_                             -> Maybe Integer
forall a. Maybe a
Nothing

isInteger :: T.Type -> Bool
isInteger :: Type -> Bool
isInteger Type
t = case Type -> Type
T.tNoUser Type
t of
      T.TCon (T.TC TC
T.TCInteger) [] -> Bool
True
      Type
_                            -> Bool
False

tyNat :: T.Type -> Maybe Integer
tyNat :: Type -> Maybe Integer
tyNat Type
t = case Type -> Type
T.tNoUser Type
t of
      T.TCon (T.TC (T.TCNum Integer
n)) [] -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
n
      Type
_                            -> Maybe Integer
forall a. Maybe a
Nothing

-- | The modulus of a @Z n@ instance type.
zN :: T.Type -> Maybe Integer
zN :: Type -> Maybe Integer
zN Type
t = case Type -> Type
T.tNoUser Type
t of
      T.TCon (T.TC TC
T.TCIntMod) [Type
n] -> Type -> Maybe Integer
tyNat Type
n
      Type
_                            -> Maybe Integer
forall a. Maybe a
Nothing

-- | The type of a subexpression, reconstructed from the schemas in scope.
exprTy :: TEnv -> T.Expr -> Either Text T.Type
exprTy :: TEnv -> Expr -> Either Text Type
exprTy TEnv
env Expr
e = Type -> Either Text Type
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Either Text Type) -> Type -> Either Text Type
forall a b. (a -> b) -> a -> b
$ Map Name Schema -> Expr -> Type
T.fastTypeOf (TEnv -> Map Name Schema
teTypes TEnv
env) Expr
e

tshow :: T.Type -> Text
tshow :: Type -> Text
tshow = FilePath -> Text
T.pack (FilePath -> Text) -> (Type -> FilePath) -> Type -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> FilePath
forall a. Show a => a -> FilePath
show (Doc -> FilePath) -> (Type -> Doc) -> Type -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Doc
forall a. PP a => a -> Doc
pp

-- | An application spine, stripping locations and proofs and collecting
--   type applications (which survive specialization only on
--   constructors, whose instantiation they carry).
spine :: T.Expr -> (T.Expr, [T.Type], [T.Expr])
spine :: Expr -> (Expr, [Type], [Expr])
spine = [Type] -> [Expr] -> Expr -> (Expr, [Type], [Expr])
go [] []
      where go :: [T.Type] -> [T.Expr] -> T.Expr -> (T.Expr, [T.Type], [T.Expr])
            go :: [Type] -> [Expr] -> Expr -> (Expr, [Type], [Expr])
go [Type]
tacc [Expr]
acc = \ case
                  T.ELocated Range
_ Expr
e -> [Type] -> [Expr] -> Expr -> (Expr, [Type], [Expr])
go [Type]
tacc [Expr]
acc Expr
e
                  T.EProofApp Expr
e  -> [Type] -> [Expr] -> Expr -> (Expr, [Type], [Expr])
go [Type]
tacc [Expr]
acc Expr
e
                  T.EApp Expr
f Expr
a     -> [Type] -> [Expr] -> Expr -> (Expr, [Type], [Expr])
go [Type]
tacc (Expr
a Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
: [Expr]
acc) Expr
f
                  T.ETApp Expr
e Type
t    -> [Type] -> [Expr] -> Expr -> (Expr, [Type], [Expr])
go (Type
t Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
tacc) [Expr]
acc Expr
e
                  Expr
e              -> (Expr
e, [Type]
tacc, [Expr]
acc)

-- | The (arguments, result) of a function type.
flatFun :: T.Type -> ([T.Type], T.Type)
flatFun :: Type -> ([Type], Type)
flatFun Type
t = case Type -> Type
T.tNoUser Type
t of
      T.TCon (T.TC TC
T.TCFun) [Type
a, Type
b] -> let ([Type]
as, Type
r) = Type -> ([Type], Type)
flatFun Type
b in (Type
a Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
as, Type
r)
      Type
_                            -> ([], Type
t)

-- | Hyle signature widths from a (monomorphic) schema.
sigWidths :: T.Schema -> Either Text ([A.Size], A.Size)
sigWidths :: Schema -> Either Text ([Size], Size)
sigWidths (T.Forall [TParam]
tvs [Type]
props Type
ty)
      | Bool -> Bool
not ([TParam] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TParam]
tvs) Bool -> Bool -> Bool
|| Bool -> Bool
not ([Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
props) = Text -> Either Text ([Size], Size)
forall a b. a -> Either a b
Left Text
"cryptol: a definition failed to specialize to a monomorphic type (rwcry bug?)."
      | Bool
otherwise = do
            let ([Type]
as, Type
r) = Type -> ([Type], Type)
flatFun Type
ty
            as' <- (Type -> Either Text Integer) -> [Type] -> Either Text [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> Either Text Integer
tyWidth [Type]
as
            r'  <- tyWidth r
            pure (map fromIntegral as', fromIntegral r')

-- | Legal (bare) Hyle name characters.
sanitize :: Text -> Text
sanitize :: Text -> Text
sanitize = (Char -> Char) -> Text -> Text
T.map (\ Char
c -> if Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> FilePath -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (FilePath
"_.$'" :: String) then Char
c else Char
'.')