packages feed

morley 1.10.0 → 1.11.0

raw patch · 22 files changed

+766/−275 lines, 22 files

Files

CHANGES.md view
@@ -1,3 +1,22 @@+1.11.0+======+* [!731](https://gitlab.com/morley-framework/morley/-/merge_requests/731)+  + Added opportunity to reorder fields in `GenericStrategy`.+  + Added `GenericStrategy`-ies for compatibility with LIGO.+* [!724](https://gitlab.com/morley-framework/morley/-/merge_requests/724)+  Fixed `UNPACK` to accept pairs of comparable types.+* [!712](https://gitlab.com/morley-framework/morley/-/merge_requests/712)+  + In optimizer, by default lambdas are now also handled.+  + Field names in optimizer config are changed (prefix added).+* [!726](https://gitlab.com/morley-framework/morley/-/merge_requests/726)+  Added `Data` and `Plated` instances to `Morley.Micheline.Expression`.+* [!723](https://gitlab.com/morley-framework/morley/-/merge_requests/723)+  * Splitted `class ContainsDoc` into `ContainsDoc` and `ContainsUpdateableDoc`;+  * Allow avoiding explicit `DName` call (now `docGroup "Title"` works).+* [!684](https://gitlab.com/morley-framework/morley/-/merge_requests/684)+  Simplify working with autodoc in contracts.+  (follow the deprecation warnings in case this hits you).+ 1.10.0 ====== * [!692](https://gitlab.com/morley-framework/morley/-/merge_requests/692)
morley.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morley-version:        1.10.0+version:        1.11.0 synopsis:       Developer tools for the Michelson Language description:    A library to make writing smart contracts in Michelson — the smart contract language of the Tezos blockchain — pleasant and effective. category:       Language@@ -87,6 +87,7 @@       Michelson.Typed.Entrypoints       Michelson.Typed.Extract       Michelson.Typed.Haskell+      Michelson.Typed.Haskell.Compatibility       Michelson.Typed.Haskell.Doc       Michelson.Typed.Haskell.Instr       Michelson.Typed.Haskell.Instr.Helpers
src/Michelson/Doc.hs view
@@ -37,6 +37,13 @@   , docGroupContent   , docDefinitionRef   , mdTocFromRef+  , WithFinalizedDoc (..)+  , finalizedAsIs+  , ContainsDoc (..)+  , ContainsUpdateableDoc (..)+  , buildDoc+  , buildMarkdownDoc+  , modifyDoc    , DGeneralInfoSection (..)   , DName (..)@@ -49,6 +56,9 @@   , DAnchor (..)   , DToc (..)   , DConversionInfo (..)+  , attachGitInfo+  , attachToc+  , attachDocCommons   ) where  import qualified Data.Map as M@@ -558,6 +568,56 @@            SomeDocItem d -> docItemToBlockGeneral d (Just sub)   } +-- | Everything that contains doc items that can be used to render the+-- documentation.+class ContainsDoc a where+  -- | Gather documentation.+  --+  -- Calling this method directly is discouraged in prod, see 'buildDoc' instead.+  -- Using this method in tests is fine though.+  buildDocUnfinalized :: a -> ContractDoc++-- | Some contract languages may support documentation update.+class ContainsDoc a => ContainsUpdateableDoc a where+  -- | Modify all documentation items recursively.+  modifyDocEntirely :: (SomeDocItem -> SomeDocItem) -> a -> a++-- | Often there is some tuning recommended prior to rendering the contract,+-- like attaching git revision info; this type designates that those last changes+-- were applied.+--+-- For example, at Michelson level you may want to use 'attachDocCommons'.+--+-- If you want no special tuning (e.g. for tests), say that explicitly with+-- 'finalizedAsIs'.+newtype WithFinalizedDoc a = WithFinalizedDoc (Identity a)+  deriving newtype (Functor, Applicative, Monad)++-- | Mark the code with doc as finalized without any changes.+finalizedAsIs :: a -> WithFinalizedDoc a+finalizedAsIs = WithFinalizedDoc . Identity++-- | Gather documenation.+buildDoc :: ContainsDoc a => WithFinalizedDoc a -> ContractDoc+buildDoc (WithFinalizedDoc (Identity a)) = buildDocUnfinalized a++-- | Construct and format documentation in textual form.+buildMarkdownDoc :: ContainsDoc a => WithFinalizedDoc a -> LText+buildMarkdownDoc = contractDocToMarkdown . buildDoc++-- | Recursevly traverse doc items and modify those that match given type.+--+-- If mapper returns 'Nothing', doc item will remain unmodified.+modifyDoc+  :: (ContainsUpdateableDoc a, DocItem i1, DocItem i2)+  => (i1 -> Maybe i2) -> a -> a+modifyDoc mapper = modifyDocEntirely untypedMapper+  where+  untypedMapper sdi@(SomeDocItem di) = fromMaybe sdi $ do+    di' <- cast di+    newDi <- mapper di'+    return (SomeDocItem newDi)+ ---------------------------------------------------------------------------- -- Basic doc items ----------------------------------------------------------------------------@@ -588,6 +648,12 @@   docItemToToc lvl (DName _ doc) =     subDocToToc (nextHeaderLevel lvl) doc +-- | This instance allows writing something like @docGroup "Title"@,+-- this makes sense as the most primitive and basic use case for doc groups+-- is putting a section under name.+instance (di ~ DName) => IsString (SubDoc -> di) where+  fromString = DName . fromString+ -- | Description of something. data DDescription = DDescription Markdown @@ -726,3 +792,27 @@     \[`Lorentz.Pack`](https://gitlab.com/morley-framework/morley/-/blob/2441e26bebd22ac4b30948e8facbb698d3b25c6d/code/lorentz/src/Lorentz/Pack.hs).\n\n\     \* Construct values for this contract directly on Michelson level using types provided in the \     \documentation."++-- | Attach information about git revision.+-- The code must contain git revision placeholder.+--+-- We do this in two stages because we use TH to deduce git revision information+-- at compile time, and this is best to be done in the very end to recompile+-- less modules.+attachGitInfo :: ContainsUpdateableDoc a => DGitRevision -> a -> WithFinalizedDoc a+attachGitInfo gitRev = finalizedAsIs ... modifyDoc $ \case+  DGitRevisionUnknown -> Just gitRev+  _ -> Nothing++attachToc :: ContainsUpdateableDoc a => DToc -> a -> WithFinalizedDoc a+attachToc toc = finalizedAsIs ... modifyDoc $ \case+  DToc "" -> Just toc+  _ -> Nothing++-- | Attach common information that is available only in the end.+attachDocCommons :: ContainsUpdateableDoc a => DGitRevision -> a -> WithFinalizedDoc a+attachDocCommons gitRev code = do+  let toc = DToc $ contractDocToToc (buildDocUnfinalized code)+  pure code+    >>= attachGitInfo gitRev+    >>= attachToc toc
src/Michelson/Interpret.hs view
@@ -13,9 +13,11 @@   , SomeItStack (..)   , MorleyLogs (..)   , noMorleyLogs+  , pickMorleyLogs    , interpret   , interpretInstr+  , interpretInstrAnnotated   , ContractReturn    , mkInitStack@@ -24,6 +26,7 @@   , InterpretResult (..)   , EvalM   , InterpreterStateMonad (..)+  , StkEl (..)   , InstrRunner   , runInstr   , runInstrNoGas@@ -44,6 +47,7 @@ import qualified Data.Set as Set import Data.Singletons (Sing) import Data.Vinyl (Rec(..), (<+>))+import Data.Vinyl.Recursive (rmap) import Fmt (Buildable(build), Builder, blockListF, prettyLn)  import Michelson.Interpret.Pack (packValue')@@ -134,7 +138,7 @@ deriving stock instance Show InterpretError  instance Buildable InterpretError where-  build (InterpretError (mf, logs)) = prettyLn mf <> "MorleyLogs are:\n" <> build logs+  build (InterpretError (mf, _)) = prettyLn mf  data InterpretResult where   InterpretResult@@ -158,15 +162,16 @@   , iurNewState = st   } --- | Morley logs for interpreter state.-newtype MorleyLogs = MorleyLogs-  { unMorleyLogs :: [Text]-    -- ^ Logs in reverse order.-  } deriving stock (Eq, Show, Generic)-    deriving newtype Default+-- | Morley logs for interpreter state that are stored in reverse order.+newtype MorleyLogs = MorleyLogs [Text]+  deriving stock (Eq, Show, Generic)+  deriving newtype Default +pickMorleyLogs :: MorleyLogs -> [Text]+pickMorleyLogs (MorleyLogs logs) = reverse logs+ instance Buildable MorleyLogs where-  build (MorleyLogs logs) = blockListF $ reverse logs+  build = blockListF . pickMorleyLogs  instance NFData MorleyLogs @@ -182,37 +187,57 @@ handleContractReturn (ei, s) =   bimap (InterpretError . (, isMorleyLogs s)) (constructIR . (, s)) ei +-- | Function to change amount of remaining steps stored in State monad+-- | Helper function to convert a record of @Value@ to @StkEl@. These will be+-- created with @starNotes@.+mapToStkEl :: Rec T.Value inp -> Rec StkEl inp+mapToStkEl = rmap starNotesStkEl++-- | Helper function to convert a record of @StkEl@ to @Value@. Any present+-- notes will be discarded.+mapToValue :: Rec StkEl inp -> Rec T.Value inp+mapToValue = rmap seValue+ interpret'   :: forall cp st arg.-     ContractCode cp st+     Contract cp st   -> EntrypointCallT cp arg   -> T.Value arg   -> T.Value st   -> ContractEnv   -> InterpreterState   -> ContractReturn st-interpret' instr epc param initSt env ist = first (fmap fromFinalStack) $+interpret' Contract{..} epc param initSt env ist = first (fmap fromFinalStack) $   runEvalOp-    (runInstr instr $ mkInitStack (liftCallArg epc param) initSt)+    (runInstr cCode $ mkInitStack (liftCallArg epc param) cParamNotes initSt cStoreNotes)     env     ist -mkInitStack :: T.Value param -> T.Value st -> Rec T.Value (ContractInp param st)-mkInitStack param st = T.VPair (param, st) :& RNil+mkInitStack+  :: T.Value param+  -> T.ParamNotes param+  -> T.Value st+  -> T.Notes st+  -> Rec StkEl (ContractInp param st)+mkInitStack param T.ParamNotesUnsafe{..} st stNotes = StkEl+  (T.VPair (param, st))+  U.noAnn+  (T.NTPair U.noAnn (U.convAnn pnRootAnn) U.noAnn pnNotes stNotes)+    :& RNil -fromFinalStack :: Rec T.Value (ContractOut st) -> ([T.Operation], T.Value st)-fromFinalStack (T.VPair (T.VList ops, st) :& RNil) =+fromFinalStack :: Rec StkEl (ContractOut st) -> ([T.Operation], T.Value st)+fromFinalStack (StkEl (T.VPair (T.VList ops, st)) _ _ :& RNil) =   (map (\(T.VOp op) -> op) ops, st)  interpret-  :: ContractCode cp st+  :: Contract cp st   -> EntrypointCallT cp arg   -> T.Value arg   -> T.Value st   -> ContractEnv   -> ContractReturn st-interpret instr epc param initSt env =-  interpret' instr epc param initSt env (initInterpreterState env)+interpret contract epc param initSt env =+  interpret' contract epc param initSt env (initInterpreterState env)  initInterpreterState :: ContractEnv -> InterpreterState initInterpreterState env = InterpreterState def (ceMaxSteps env) (OriginationIndex 0)@@ -226,10 +251,21 @@   -> Instr inp out   -> Rec T.Value inp   -> Either MichelsonFailed (Rec T.Value out)-interpretInstr env instr inpSt =+interpretInstr = fmap mapToValue ... interpretInstrAnnotated++-- | Interpret an instruction in vacuum, putting no extra contraints on+-- its execution while preserving its annotations.+--+-- Mostly for testing purposes.+interpretInstrAnnotated+  :: ContractEnv+  -> Instr inp out+  -> Rec T.Value inp+  -> Either MichelsonFailed (Rec StkEl out)+interpretInstrAnnotated env instr inpSt =   fst $   runEvalOp-    (runInstr instr inpSt)+    (runInstr instr $ mapToStkEl inpSt)     env     InterpreterState       { isMorleyLogs = MorleyLogs []@@ -238,7 +274,7 @@       }  data SomeItStack where-  SomeItStack :: T.ExtInstr inp -> Rec T.Value inp -> SomeItStack+  SomeItStack :: T.ExtInstr inp -> Rec StkEl inp -> SomeItStack  newtype RemainingSteps = RemainingSteps Word64   deriving stock (Show, Generic)@@ -294,13 +330,22 @@   , MonadError MichelsonFailed m   ) +data StkEl t = StkEl+  { seValue :: Value t+  , seVarAnn :: U.VarAnn+  , seNotes :: Notes t+  } deriving stock (Eq, Show)++starNotesStkEl :: forall t. Value t -> StkEl t+starNotesStkEl v = StkEl v U.noAnn $ withValueTypeSanity v $ starNotes @t+ type InstrRunner m =   forall inp out.      Instr inp out-  -> Rec (T.Value) inp-  -> m (Rec (T.Value) out)+  -> Rec StkEl inp+  -> m (Rec StkEl out) --- | Function to change amount of remaining steps stored in State monad+-- | Function to change amount of remaining steps stored in State monad. runInstr :: EvalM m => InstrRunner m runInstr i@(Seq _i1 _i2) r = runInstrImpl runInstr i r runInstr i@(WithLoc _ _) r = runInstrImpl runInstr i r@@ -311,7 +356,7 @@ runInstr i r = do   rs <- isRemainingSteps <$> getInterpreterState   if rs == 0-  then throwError $ MichelsonGasExhaustion+  then throwError MichelsonGasExhaustion   else do     modifyInterpreterState (\s -> s {isRemainingSteps = rs - 1})     runInstrImpl runInstr i r@@ -323,15 +368,25 @@ runInstrImpl :: EvalM m => InstrRunner m -> InstrRunner m runInstrImpl runner (Seq i1 i2) r = runner i1 r >>= \r' -> runner i2 r' runInstrImpl runner (WithLoc _ i) r = runner i r-runInstrImpl runner (InstrWithNotes _ i) r = runner i r-runInstrImpl runner (InstrWithVarNotes _ i) r = runner i r+runInstrImpl runner (InstrWithNotes (PackedNotes n) i) inp =+  runner i inp <&> \case+    StkEl v vn _ :& r -> StkEl v vn n :& r+runInstrImpl runner (InstrWithVarNotes (toList -> vns) i) inp = do+  out <- runner i inp+  let zipRec :: [U.VarAnn] -> Rec StkEl rs -> Rec StkEl rs+      zipRec [] RNil = RNil+      zipRec (vn : rs) stk = case stk of+        StkEl v _ n :& r -> StkEl v vn n :& zipRec rs r+        RNil -> error "Output stack is exhausted but there are still var annotations"+      zipRec [] sm = sm+  pure $ zipRec vns out runInstrImpl runner (FrameInstr (_ :: Proxy s) i) r = do   let (inp, end) = rsplit @_ @_ @s r   out <- runInstrImpl runner i inp   return (out <+> end) runInstrImpl _ Nop r = pure $ r-runInstrImpl _ (Ext nop) r = r <$ interpretExt (SomeItStack nop r)-runInstrImpl runner (Nested sq) r = runInstrImpl runner sq r+runInstrImpl runner (Ext nop) r = r <$ interpretExt runner (SomeItStack nop r)+runInstrImpl runner (Nested sq) r = runner sq r runInstrImpl runner (DocGroup _ sq) r = runInstrImpl runner sq r runInstrImpl _ DROP (_ :& r) = pure $ r runInstrImpl runner (DROPN s) stack =@@ -352,7 +407,7 @@   pure $ go (nSing0, input0)   where     go :: forall (n :: Peano) inp out a. T.ConstraintDIG n inp out a =>-      (Sing n, Rec T.Value inp) -> Rec T.Value out+      (Sing n, Rec StkEl inp) -> Rec StkEl out     go = \case       (SZ, stack) ->  stack       (SS nSing, b :& r) -> case go (nSing, r) of@@ -361,75 +416,82 @@   pure $ go (nSing0, input0)   where     go :: forall (n :: Peano) inp out a. T.ConstraintDUG n inp out a =>-      (Sing n, Rec T.Value inp) -> Rec T.Value out+      (Sing n, Rec StkEl inp) -> Rec StkEl out     go = \case       (SZ, stack) -> stack       (SS s', a :& b :& r) -> b :& go (s', a :& r)-runInstrImpl _ SOME (a :& r) =+runInstrImpl _ SOME ((seValue -> a) :& r) =   withValueTypeSanity a $-    pure $ VOption (Just a) :& r-runInstrImpl _ (PUSH v) r = pure $ v :& r-runInstrImpl _ NONE r = pure $ VOption Nothing :& r-runInstrImpl _ UNIT r = pure $ VUnit :& r-runInstrImpl runner (IF_NONE _bNone bJust) (VOption (Just a) :& r) = runner bJust (a :& r)-runInstrImpl runner (IF_NONE bNone _bJust) (VOption Nothing :& r) = runner bNone r-runInstrImpl _ (AnnPAIR{}) (a :& b :& r) = pure $ VPair (a, b) :& r-runInstrImpl _ (AnnCAR _) (VPair (a, _b) :& r) = pure $ a :& r-runInstrImpl _ (AnnCDR _) (VPair (_a, b) :& r) = pure $ b :& r-runInstrImpl _ LEFT (a :& r) =+    pure $ starNotesStkEl (VOption (Just a)) :& r+runInstrImpl _ (PUSH v) r = pure $ starNotesStkEl v :& r+runInstrImpl _ NONE r = pure $ starNotesStkEl (VOption Nothing) :& r+runInstrImpl _ UNIT r = pure $ starNotesStkEl VUnit :& r+runInstrImpl runner (IF_NONE _bNone bJust) (StkEl (VOption (Just a)) _ _ :& r) =+  runner bJust (starNotesStkEl a :& r)+runInstrImpl runner (IF_NONE bNone _bJust) (StkEl (VOption Nothing) _ _ :& r) =+  runner bNone r+runInstrImpl _ (AnnPAIR nt nf1 nf2) ((StkEl a _ na) :& (StkEl b _ nb) :& r) =+  pure $ StkEl (VPair (a, b)) U.noAnn (NTPair nt nf1 nf2 na nb) :& r+runInstrImpl _ (AnnCAR _) (StkEl (VPair (a, _b)) _ _ :& r) = pure $ starNotesStkEl a :& r+runInstrImpl _ (AnnCDR _) (StkEl (VPair (_a, b)) _ _ :& r) = pure $ starNotesStkEl b :& r+runInstrImpl _ LEFT ((seValue -> a) :& r) =   withValueTypeSanity a $-    pure $ (VOr $ Left a) :& r-runInstrImpl _ RIGHT (b :& r) =+    pure $ starNotesStkEl (VOr $ Left a) :& r+runInstrImpl _ RIGHT ((seValue -> b) :& r) =   withValueTypeSanity b $-    pure $ (VOr $ Right b) :& r-runInstrImpl runner (IF_LEFT bLeft _) (VOr (Left a) :& r) = runner bLeft (a :& r)-runInstrImpl runner (IF_LEFT _ bRight) (VOr (Right a) :& r) = runner bRight (a :& r)+    pure $ starNotesStkEl (VOr $ Right b) :& r+runInstrImpl runner (IF_LEFT bLeft _) (StkEl (VOr (Left a)) _ _ :& r) =+  runner bLeft (starNotesStkEl a :& r)+runInstrImpl runner (IF_LEFT _ bRight) (StkEl (VOr (Right a)) _ _ :& r) =+  runner bRight (starNotesStkEl a :& r) -- More here-runInstrImpl _ NIL r = pure $ VList [] :& r-runInstrImpl _ CONS (a :& VList l :& r) = pure $ VList (a : l) :& r-runInstrImpl runner (IF_CONS _ bNil) (VList [] :& r) = runner bNil r-runInstrImpl runner (IF_CONS bCons _) (VList (lh : lr) :& r) = runner bCons (lh :& VList lr :& r)-runInstrImpl _ SIZE (a :& r) = pure $ (VNat $ (fromInteger . toInteger) $ evalSize a) :& r-runInstrImpl _ EMPTY_SET r = pure $ VSet Set.empty :& r-runInstrImpl _ EMPTY_MAP r = pure $ VMap Map.empty :& r-runInstrImpl _ EMPTY_BIG_MAP r = pure $ VBigMap Map.empty :& r-runInstrImpl runner (MAP ops) (a :& r) =+runInstrImpl _ NIL r = pure $ starNotesStkEl (VList []) :& r+runInstrImpl _ CONS (a :& StkEl (VList l) _ _ :& r) = pure $ starNotesStkEl (VList (seValue a : l)) :& r+runInstrImpl runner (IF_CONS _ bNil) (StkEl (VList []) _ _ :& r) = runner bNil r+runInstrImpl runner (IF_CONS bCons _) (StkEl (VList (lh : lr)) _ _ :& r) =+  runner bCons (starNotesStkEl lh :& starNotesStkEl (VList lr) :& r)+runInstrImpl _ SIZE (a :& r) = pure $ starNotesStkEl (VNat $ (fromInteger . toInteger) $ evalSize $ seValue a) :& r+runInstrImpl _ EMPTY_SET r = pure $ starNotesStkEl (VSet Set.empty) :& r+runInstrImpl _ EMPTY_MAP r = pure $ starNotesStkEl (VMap Map.empty) :& r+runInstrImpl _ EMPTY_BIG_MAP r = pure $ starNotesStkEl (VBigMap Map.empty) :& r+runInstrImpl runner (MAP ops) ((seValue -> a) :& r) =   case ops of     (code :: Instr (MapOpInp c ': s) (b ': s)) -> do       -- Evaluation must preserve all stack modifications that @MAP@'s does.-      (newStack, newList) <- foldlM (\(curStack, curList) (val :: T.Value (MapOpInp c)) -> do+      (newStack, newList) <- foldlM (\(curStack, curList) (val :: StkEl (MapOpInp c)) -> do         res <- runner code (val :& curStack)         case res of-          ((nextVal :: T.Value b) :& nextStack) -> pure (nextStack, nextVal : curList))-        (r, []) (mapOpToList @c a)-      pure $ mapOpFromList a (reverse newList) :& newStack+          ((seValue -> nextVal :: T.Value b) :& nextStack) -> pure (nextStack, nextVal : curList))+        (r, []) (starNotesStkEl <$> mapOpToList @c a)+      pure $ starNotesStkEl (mapOpFromList a (reverse newList)) :& newStack runInstrImpl runner (ITER ops) (a :& r) =   case ops of     (code :: Instr (IterOpEl c ': s) s) ->-      case iterOpDetachOne @c a of+      case iterOpDetachOne @c (seValue a) of         (Just x, xs) -> do-          res <- runner code (x :& r)-          runner (ITER code) (xs :& res)+          res <- runner code (starNotesStkEl x :& r)+          runner (ITER code) (starNotesStkEl xs :& res)         (Nothing, _) -> pure r-runInstrImpl _ MEM (a :& b :& r) = pure $ (VBool (evalMem a b)) :& r-runInstrImpl _ GET (a :& b :& r) = pure $ VOption (evalGet a b) :& r-runInstrImpl _ UPDATE (a :& b :& c :& r) = pure $ evalUpd a b c :& r-runInstrImpl runner (IF bTrue _) (VBool True :& r) = runner bTrue r-runInstrImpl runner (IF _ bFalse) (VBool False :& r) = runner bFalse r-runInstrImpl _ (LOOP _) (VBool False :& r) = pure $ r-runInstrImpl runner (LOOP ops) (VBool True :& r) = do+runInstrImpl _ MEM (a :& b :& r) = pure $ starNotesStkEl (VBool (evalMem (seValue a) (seValue b))) :& r+runInstrImpl _ GET (a :& b :& r) = pure $ starNotesStkEl (VOption (evalGet (seValue a) (seValue b))) :& r+runInstrImpl _ UPDATE (a :& b :& c :& r) =+    pure $ starNotesStkEl (evalUpd (seValue a) (seValue b) (seValue c)) :& r+runInstrImpl runner (IF bTrue _) (StkEl (VBool True) _ _ :& r) = runner bTrue r+runInstrImpl runner (IF _ bFalse) (StkEl (VBool False) _ _ :& r) = runner bFalse r+runInstrImpl _ (LOOP _) (StkEl (VBool False) _ _ :& r) = pure $ r+runInstrImpl runner (LOOP ops) (StkEl (VBool True) _ _ :& r) = do   res <- runner ops r   runner (LOOP ops) res-runInstrImpl _ (LOOP_LEFT _) (VOr (Right a) :&r) = pure $ a :& r-runInstrImpl runner (LOOP_LEFT ops) (VOr (Left a) :& r) = do-  res <- runner ops (a :& r)-  runner  (LOOP_LEFT ops) res-runInstrImpl _ (LAMBDA lam) r = pure $ lam :& r-runInstrImpl runner EXEC (a :& VLam (T.rfAnyInstr -> lBody) :& r) = do+runInstrImpl _ (LOOP_LEFT _) (StkEl (VOr (Right a)) _ _ :& r) = pure $ starNotesStkEl a :& r+runInstrImpl runner (LOOP_LEFT ops) (StkEl (VOr (Left a)) _ _ :& r) = do+  res <- runner ops (starNotesStkEl a :& r)+  runner (LOOP_LEFT ops) res+runInstrImpl _ (LAMBDA lam) r = pure $ starNotesStkEl lam :& r+runInstrImpl runner EXEC (a :& StkEl (VLam (T.rfAnyInstr -> lBody)) _ _ :& r) = do   res <- runner lBody (a :& RNil)   pure $ res <+> r-runInstrImpl _ APPLY ((a :: T.Value a) :& VLam lBody :& r) = do-  pure $ VLam (T.rfMapAnyInstr doApply lBody) :& r+runInstrImpl _ APPLY (StkEl (a :: T.Value a) _ _ :& StkEl (VLam lBody) _ _ :& r) = do+  pure $ starNotesStkEl (VLam (T.rfMapAnyInstr doApply lBody)) :& r   where     doApply :: Instr ('TPair a i ': s) o -> Instr (i ': s) o     doApply b = PUSH a `Seq` PAIR `Seq` Nested b@@ -441,47 +503,56 @@     SZ -> runner i stack     SS s' -> case stack of       (a :& r) -> (a :&) <$> runInstrImpl runner (DIPN s' i) r-runInstrImpl _ FAILWITH (a :& _) = throwError $ MichelsonFailedWith a-runInstrImpl _ CAST (a :& r) = pure $ a :& r-runInstrImpl _ RENAME (a :& r) = pure $ a :& r-runInstrImpl _ PACK (a :& r) = pure $ (VBytes $ packValue' a) :& r-runInstrImpl _ UNPACK (VBytes a :& r) =-  pure $ (VOption . rightToMaybe $ runUnpack a) :& r-runInstrImpl _ CONCAT (a :& b :& r) = pure $ evalConcat a b :& r-runInstrImpl _ CONCAT' (VList a :& r) = pure $ evalConcat' a :& r-runInstrImpl _ SLICE (VNat o :& VNat l :& s :& r) =-  pure $ VOption (evalSlice o l s) :& r-runInstrImpl _ ISNAT (VInt i :& r) =+runInstrImpl _ FAILWITH (a :& _) = throwError $ MichelsonFailedWith (seValue a)+runInstrImpl _ CAST (StkEl a vn _ :& r) = pure $ StkEl a vn starNotes :& r+runInstrImpl _ RENAME (StkEl a _ n :& r) = pure $ StkEl a U.noAnn n :& r+runInstrImpl _ PACK ((seValue -> a) :& r) = pure $ starNotesStkEl (VBytes $ packValue' a) :& r+runInstrImpl _ UNPACK (StkEl (VBytes a) _ _ :& r) =+  pure $ starNotesStkEl (VOption . rightToMaybe $ runUnpack a) :& r+runInstrImpl _ CONCAT (a :& b :& r) = pure $ starNotesStkEl (evalConcat (seValue a) (seValue b)) :& r+runInstrImpl _ CONCAT' (StkEl (VList a) _ _ :& r) = pure $ starNotesStkEl (evalConcat' a) :& r+runInstrImpl _ SLICE (StkEl (VNat o) _ _ :& StkEl (VNat l) _ _ :& StkEl s _ _ :& r) =+  pure $ starNotesStkEl (VOption (evalSlice o l s)) :& r+runInstrImpl _ ISNAT (StkEl (VInt i) _ _ :& r) =   if i < 0-  then pure $ VOption Nothing :& r-  else pure $ VOption (Just (VNat $ fromInteger i)) :& r-runInstrImpl _ ADD (l :& r :& rest) =-  (:& rest) <$> runArithOp (Proxy @Add) l r+  then pure $ starNotesStkEl (VOption Nothing) :& r+  else pure $ starNotesStkEl (VOption (Just (VNat $ fromInteger i))) :& r+runInstrImpl _ ADD (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Add) l r runInstrImpl _ SUB (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Sub) l r runInstrImpl _ MUL (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Mul) l r-runInstrImpl _ EDIV (l :& r :& rest) = pure $ evalEDivOp l r :& rest-runInstrImpl _ ABS (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Abs) a) :& rest-runInstrImpl _ NEG (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Neg) a) :& rest+runInstrImpl _ EDIV (l :& r :& rest) = pure $ starNotesStkEl (evalEDivOp (seValue l) (seValue r)) :& rest+runInstrImpl _ ABS ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Abs) a) :& rest+runInstrImpl _ NEG ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Neg) a) :& rest runInstrImpl _ LSL (x :& s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsl) x s runInstrImpl _ LSR (x :& s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsr) x s runInstrImpl _ OR (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Or) l r runInstrImpl _ AND (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @And) l r runInstrImpl _ XOR (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Xor) l r-runInstrImpl _ NOT (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Not) a) :& rest-runInstrImpl _ COMPARE (l :& r :& rest) = pure $ (T.VInt (compareOp l r)) :& rest-runInstrImpl _ EQ (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Eq') a) :& rest-runInstrImpl _ NEQ (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Neq) a) :& rest-runInstrImpl _ LT (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Lt) a) :& rest-runInstrImpl _ GT (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Gt) a) :& rest-runInstrImpl _ LE (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Le) a) :& rest-runInstrImpl _ GE (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Ge) a) :& rest-runInstrImpl _ INT (VNat n :& r) = pure $ (VInt $ toInteger n) :& r+runInstrImpl _ NOT ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Not) a) :& rest+runInstrImpl _ COMPARE ((seValue -> l) :& (seValue -> r) :& rest) =+  pure $ starNotesStkEl (T.VInt (compareOp l r)) :& rest+runInstrImpl _ EQ ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Eq') a) :& rest+runInstrImpl _ NEQ ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Neq) a) :& rest+runInstrImpl _ LT ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Lt) a) :& rest+runInstrImpl _ GT ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Gt) a) :& rest+runInstrImpl _ LE ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Le) a) :& rest+runInstrImpl _ GE ((seValue -> a) :& rest) =+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Ge) a) :& rest+runInstrImpl _ INT (StkEl (VNat n) _ _ :& r) = pure $ starNotesStkEl (VInt $ toInteger n) :& r runInstrImpl _ (SELF sepc :: Instr inp out) r = do   ContractEnv{..} <- ask   case Proxy @out of     (_ :: Proxy ('TContract cp ': s)) -> do-      pure $ VContract ceSelf sepc :& r-runInstrImpl _ (CONTRACT (nt :: T.Notes a) instrEpName) (VAddress epAddr :& r) = do+      pure $ starNotesStkEl (VContract ceSelf sepc) :& r+runInstrImpl _ (CONTRACT (nt :: T.Notes a) instrEpName) (StkEl (VAddress epAddr) _ _ :& r) = do   ContractEnv{..} <- ask   let T.EpAddress addr addrEpName = epAddr   let mepName =@@ -491,18 +562,16 @@           (en, DefEpName) -> Just en           _ -> Nothing -  pure $ case mepName of-    Nothing ->-      VOption Nothing :& r+  let withNotes v = StkEl v U.noAnn (NTOption U.noAnn $ NTContract U.noAnn nt) :& r+  pure $ withNotes $ case mepName of+    Nothing -> VOption Nothing     Just epName ->       case addr of-        KeyAddress _ ->-          castContract addr epName T.tyImplicitAccountParam :& r+        KeyAddress _ -> castContract addr epName T.tyImplicitAccountParam         ContractAddress ca ->           case Map.lookup ca ceContracts of-            Just (SomeParamType _ paramNotes) ->-              castContract addr epName paramNotes :& r-            Nothing -> VOption Nothing :& r+            Just (SomeParamType _ paramNotes) -> castContract addr epName paramNotes+            Nothing -> VOption Nothing   where   castContract     :: forall p. T.ParameterScope p@@ -513,14 +582,15 @@     Right (Refl, _) <- pure $ matchTypes nt na     return $ VContract addr (T.SomeEpc epc) -runInstrImpl _ TRANSFER_TOKENS (p :& VMutez mutez :& contract :& r) =-  pure $ VOp (OpTransferTokens $ TransferTokens p mutez contract) :& r-runInstrImpl _ SET_DELEGATE (VOption mbKeyHash :& r) =+runInstrImpl _ TRANSFER_TOKENS+  (StkEl p _ _ :& StkEl (VMutez mutez) _ _ :& StkEl contract _ _ :& r) =+  pure $ starNotesStkEl (VOp (OpTransferTokens $ TransferTokens p mutez contract)) :& r+runInstrImpl _ SET_DELEGATE (StkEl (VOption mbKeyHash) _ _ :& r) =   case mbKeyHash of-    Just (VKeyHash k) -> pure $ VOp (OpSetDelegate $ SetDelegate $ Just k) :& r-    Nothing -> pure $ VOp (OpSetDelegate $ SetDelegate $ Nothing) :& r+    Just (VKeyHash k) -> pure $ starNotesStkEl (VOp (OpSetDelegate $ SetDelegate $ Just k)) :& r+    Nothing -> pure $ starNotesStkEl (VOp (OpSetDelegate $ SetDelegate $ Nothing)) :& r runInstrImpl _ (CREATE_CONTRACT contract)-  (VOption mbKeyHash :& VMutez m :& g :& r) = do+  (StkEl (VOption mbKeyHash) _ _ :& StkEl (VMutez m) _ _ :& StkEl g _ _ :& r) = do   originator <- ceSelf <$> ask    originationNonce <- isOriginationNonce <$> getInterpreterState@@ -542,48 +612,53 @@               globalCounter   let resEpAddr = EpAddress resAddr DefEpName   let resOp = CreateContract originator (unwrapMbKeyHash mbKeyHash) m g ops-  pure $ VOp (OpCreateContract resOp)-      :& (VAddress resEpAddr)+  pure $ starNotesStkEl (VOp (OpCreateContract resOp))+      :& starNotesStkEl (VAddress resEpAddr)       :& r-runInstrImpl _ IMPLICIT_ACCOUNT (VKeyHash k :& r) =-  pure $ VContract (KeyAddress k) sepcPrimitive :& r+runInstrImpl _ IMPLICIT_ACCOUNT (StkEl (VKeyHash k) _ _ :& r) =+  pure $ (starNotesStkEl (VContract (KeyAddress k) sepcPrimitive)) :& r runInstrImpl _ NOW r = do   ContractEnv{..} <- ask-  pure $ (VTimestamp ceNow) :& r+  pure $ starNotesStkEl (VTimestamp ceNow) :& r runInstrImpl _ AMOUNT r = do   ContractEnv{..} <- ask-  pure $ (VMutez ceAmount) :& r+  pure $ starNotesStkEl (VMutez ceAmount) :& r runInstrImpl _ BALANCE r = do   ContractEnv{..} <- ask-  pure $ (VMutez ceBalance) :& r-runInstrImpl _ CHECK_SIGNATURE (VKey k :& VSignature v :&-  VBytes b :& r) = pure $ (VBool $ checkSignature k v b) :& r-runInstrImpl _ SHA256 (VBytes b :& r) = pure $ (VBytes $ sha256 b) :& r-runInstrImpl _ SHA512 (VBytes b :& r) = pure $ (VBytes $ sha512 b) :& r-runInstrImpl _ BLAKE2B (VBytes b :& r) = pure $ (VBytes $ blake2b b) :& r-runInstrImpl _ HASH_KEY (VKey k :& r) = pure $ (VKeyHash $ hashKey k) :& r+  pure $ starNotesStkEl (VMutez ceBalance) :& r+runInstrImpl _ CHECK_SIGNATURE+  (StkEl (VKey k) _ _ :& StkEl (VSignature v) _ _ :& StkEl (VBytes b) _ _ :& r) =+  pure $ starNotesStkEl (VBool $ checkSignature k v b) :& r+runInstrImpl _ SHA256 (StkEl (VBytes b) _ _ :& r) =+  pure $ starNotesStkEl (VBytes $ sha256 b) :& r+runInstrImpl _ SHA512 (StkEl (VBytes b) _ _ :& r) =+  pure $ starNotesStkEl (VBytes $ sha512 b) :& r+runInstrImpl _ BLAKE2B (StkEl (VBytes b) _ _ :& r) =+  pure $ starNotesStkEl (VBytes $ blake2b b) :& r+runInstrImpl _ HASH_KEY (StkEl (VKey k) _ _ :& r) =+  pure $ starNotesStkEl (VKeyHash $ hashKey k) :& r runInstrImpl _ SOURCE r = do   ContractEnv{..} <- ask-  pure $ (VAddress $ EpAddress ceSource DefEpName) :& r+  pure $ starNotesStkEl (VAddress $ EpAddress ceSource DefEpName) :& r runInstrImpl _ SENDER r = do   ContractEnv{..} <- ask-  pure $ (VAddress $ EpAddress ceSender DefEpName) :& r-runInstrImpl _ ADDRESS (VContract a sepc :& r) =-  pure $ (VAddress $ EpAddress a (sepcName sepc)) :& r+  pure $ starNotesStkEl (VAddress $ EpAddress ceSender DefEpName) :& r+runInstrImpl _ ADDRESS (StkEl (VContract a sepc) _ _ :& r) =+  pure $ starNotesStkEl (VAddress $ EpAddress a (sepcName sepc)) :& r runInstrImpl _ CHAIN_ID r = do   ContractEnv{..} <- ask-  pure $ VChainId ceChainId :& r+  pure $ starNotesStkEl (VChainId ceChainId) :& r  -- | Evaluates an arithmetic operation and either fails or proceeds. runArithOp   :: (ArithOp aop n m, Typeable n, Typeable m, EvalM monad)   => proxy aop-  -> Value n-  -> Value m-  -> monad (Value (ArithRes aop n m))-runArithOp op l r = case evalOp op l r of+  -> StkEl n+  -> StkEl m+  -> monad (StkEl (ArithRes aop n m))+runArithOp op l r = case evalOp op (seValue l) (seValue r) of   Left  err -> throwError (MichelsonArithError err)-  Right res -> pure res+  Right res -> pure $ starNotesStkEl res  -- | Unpacks given raw data into a typed value. runUnpack@@ -616,35 +691,36 @@ unwrapMbKeyHash :: Maybe (T.Value 'T.TKeyHash) -> Maybe KeyHash unwrapMbKeyHash mbKeyHash = mbKeyHash <&> \(VKeyHash keyHash) -> keyHash -interpretExt :: EvalM m => SomeItStack -> m ()-interpretExt (SomeItStack (T.PRINT (T.PrintComment pc)) st) = do+interpretExt :: EvalM m => InstrRunner m -> SomeItStack -> m ()+interpretExt _ (SomeItStack (T.PRINT (T.PrintComment pc)) st) = do   let getEl (Left l) = l-      getEl (Right str) = withStackElem str st show-  modifyInterpreterState (\s -> s {isMorleyLogs = MorleyLogs $ mconcat (map getEl pc) : unMorleyLogs (isMorleyLogs s)})+      getEl (Right str) = withStackElem str st (show . seValue)+      getMorleyLogs (MorleyLogs logs) = logs+  modifyInterpreterState (\s -> s {isMorleyLogs = MorleyLogs $ mconcat (map getEl pc) : getMorleyLogs (isMorleyLogs s)}) -interpretExt (SomeItStack (T.TEST_ASSERT (T.TestAssert nm pc instr)) st) = do-  ost <- runInstrNoGas instr st-  let ((T.fromVal -> succeeded) :& _) = ost+interpretExt runner (SomeItStack (T.TEST_ASSERT (T.TestAssert nm pc instr)) st) = do+  ost <- runInstrImpl runner instr st+  let ((seValue -> T.fromVal -> succeeded) :& _) = ost   unless succeeded $ do-    interpretExt (SomeItStack (T.PRINT pc) st)+    interpretExt runner (SomeItStack (T.PRINT pc) st)     throwError $ MichelsonFailedTestAssert $ "TEST_ASSERT " <> nm <> " failed" -interpretExt (SomeItStack T.DOC_ITEM{} _) = pass-interpretExt (SomeItStack T.COMMENT_ITEM{} _) = pass+interpretExt _ (SomeItStack T.DOC_ITEM{} _) = pass+interpretExt _ (SomeItStack T.COMMENT_ITEM{} _) = pass  -- | Access given stack reference (in CPS style). withStackElem   :: forall st a.      T.StackRef st-  -> Rec T.Value st-  -> (forall t. T.Value t -> a)+  -> Rec StkEl st+  -> (forall t. StkEl t -> a)   -> a withStackElem (T.StackRef sn) vals cont =   loop (vals, sn)   where     loop       :: forall s (n :: Peano). (LongerThan s n)-      => (Rec T.Value s, Sing n) -> a+      => (Rec StkEl s, Sing n) -> a     loop = \case       (e :& _, SZ) -> cont e       (_ :& es, SS n) -> loop (es, n)
src/Michelson/Interpret/Unpack.hs view
@@ -688,20 +688,19 @@     0x5D -> pure TKeyHash     0x6B -> pure TTimestamp     0x6E -> pure TAddress+    0x65 -> decodeTPair     _ -> fail failMessage   case pretag of     0x03 -> (ct,,) <$> decodeNoAnn <*> decodeNoAnn     0x04 -> decodeWithTFAnns (ct,,)     0x05 -> decodeWithTFAnns (ct,,)+    0x07 -> (ct,,) <$> decodeNoAnn <*> decodeNoAnn     _ -> fail failMessage  {-# ANN decodeTWithAnns ("HLint: ignore Redundant <$>" :: Text) #-} decodeTWithAnns :: Get (T, TypeAnn, FieldAnn)-decodeTWithAnns = doDecode <|> decodeTc ? "Type"+decodeTWithAnns = doDecode <|> decodeCTWithAnns ? "Type"   where-    decodeTc = do-      (ct, tAnn, fAnn) <- decodeCTWithAnns-      pure (ct, tAnn, fAnn)     doDecode = do       pretag <- Get.getWord8 ? "Pre complex type tag"       tag <- Get.getWord8 ? "Complex type tag"
src/Michelson/Optimizer.hs view
@@ -20,16 +20,19 @@ module Michelson.Optimizer   ( optimize   , optimizeWithConf+  , defaultOptimizerConf   , defaultRules   , defaultRulesAndPushPack   , orRule   , orSimpleRule   , Rule   , OptimizerConf (..)+  , ocGotoValuesL   ) where  import Prelude hiding (EQ) +import Control.Lens (makeLensesFor) import Data.Constraint (Dict(..)) import Data.Default (Default(def)) import Data.Singletons (sing)@@ -50,15 +53,19 @@ ----------------------------------------------------------------------------  data OptimizerConf = OptimizerConf-  { gotoValues :: Bool-  , ruleset    :: Rule -> Rule+  { ocGotoValues :: Bool+  , ocRuleset    :: Rule -> Rule   } +-- | Default config - all commonly useful rules will be applied to all the code.+defaultOptimizerConf :: OptimizerConf+defaultOptimizerConf = OptimizerConf+  { ocGotoValues = True+  , ocRuleset    = defaultRules+  }+ instance Default OptimizerConf where-  def = OptimizerConf-    { gotoValues = False-    , ruleset    = defaultRules-    }+  def = defaultOptimizerConf  -- | Optimize a typed instruction by replacing some sequences of -- instructions with smaller equivalent sequences.@@ -68,14 +75,14 @@  -- | Optimize a typed instruction using a custom set of rules. optimizeWithConf :: OptimizerConf -> Instr inp out -> Instr inp out-optimizeWithConf (OptimizerConf gotoValues rules)+optimizeWithConf (OptimizerConf ocGotoValues rules)   = (fst .)   $ dfsInstr dfsSettings   $ (adapter .)   $ applyOnce   $ fixpoint rules   where-    dfsSettings = def{ dsGoToValues = gotoValues }+    dfsSettings = def{ dsGoToValues = ocGotoValues }  ---------------------------------------------------------------------------- -- Rewrite rules@@ -362,15 +369,15 @@     pushPacked :: PackedValScope t => Value t -> Instr s ('TBytes ': s)     pushPacked = PUSH . VBytes . packValue' --- | Append LHS of 'Seq' to RHS and re-run pointwise ruleset at each point.+-- | Append LHS of 'Seq' to RHS and re-run pointwise ocRuleset at each point. --   That might cause reinvocation of this function (see 'defaultRules'), --   but productivity ensures it will flatten any 'Seq'-tree right-to-left, --   while evaling no more than once on each node. -----   The reason this function invokes ruleset is when you append an instr+--   The reason this function invokes ocRuleset is when you append an instr --   to already-optimised RHS of 'Seq', you might get an optimisable tree. -----   The argument is a local, non-structurally-recursive ruleset.+--   The argument is a local, non-structurally-recursive ocRuleset. linearizeAndReapply :: Rule -> Instr inp out -> Instr inp out linearizeAndReapply restart = \case   Seq (Seq a b) c ->@@ -410,3 +417,9 @@ whileApplies r = go   where     go i = maybe (Just i) go (r i)++----------------------------------------------------------------------------+-- TH+----------------------------------------------------------------------------++makeLensesFor [("ocGotoValues", "ocGotoValuesL")] ''OptimizerConf
src/Michelson/Runtime.hs view
@@ -599,7 +599,7 @@           }           <- liftEither $ first (EEInterpreterFailed addr) $              handleContractReturn $-                interpret (T.cCode csContract) epc+                interpret csContract epc                 typedParameter csStorage contractEnv         let           updBalance
src/Michelson/TypeCheck/Helpers.hs view
@@ -3,8 +3,7 @@ -- SPDX-License-Identifier: LicenseRef-MIT-TQ  module Michelson.TypeCheck.Helpers-    ( onLeft-    , deriveSpecialVN+    ( deriveSpecialVN     , deriveSpecialFNs     , deriveVN     , deriveNsOr@@ -40,6 +39,7 @@     , mulImpl     , edivImpl     , unaryArithImpl+    , unaryArithImplAnnotated     , withCompareableCheck     ) where @@ -69,6 +69,7 @@  import qualified Michelson.Untyped as Un import Michelson.Untyped.Annotation (Annotation(..), FieldAnn, VarAnn, ann)+import Util.Type (onFirst)  -- | Function which derives special annotations -- for PAIR instruction.@@ -144,10 +145,6 @@ convergeHST (a ::& as) (b ::& bs) =     liftA2 (::&) (convergeHSTEl a b) (convergeHST as bs) --- TODO move to Util module-onLeft :: Either a c -> (a -> b) -> Either b c-onLeft = flip first- -- | Extract singleton for each single type of the given stack. hstToTs :: HST st -> [T] hstToTs = \case@@ -163,7 +160,7 @@   case eqT @as @bs of     Nothing -> Left $ StackEqError (hstToTs hst) (hstToTs hst')     Just Refl -> do-      void $ convergeHST hst hst' `onLeft` AnnError+      void $ convergeHST hst hst' `onFirst` AnnError       return Refl  -- | Check whether the given stack has size 1 and its only element matches the@@ -244,7 +241,7 @@   => Un.ExpandedInstr -> HST ts -> Maybe TypeContext   -> Either AnnConvergeError a -> m a onTypeCheckInstrAnnErr instr i mContext ei =-  onTypeCheckInstrErr instr (SomeHST i) mContext (ei `onLeft` AnnError)+  onTypeCheckInstrErr instr (SomeHST i) mContext (ei `onFirst` AnnError)  withCompareableCheck   :: forall a m v ts. (Typeable ts, MonadReader InstrCallStack m, MonadError TCError m)@@ -353,6 +350,9 @@   -> TypeCheckInstrNoExcept (TypeCheckedSeq inp) typeCheckImplNoLastTypeComment _ [] inputStack   = pure (WellTypedSeq (inputStack :/ Nop ::: inputStack))+typeCheckImplNoLastTypeComment tcInstr [op] inputStack = do+  typeCheckOpImpl tcInstr op inputStack+      >>= mapMSeq prependStackTypeComment typeCheckImplNoLastTypeComment tcInstr (op : ops) inputStack = do   done <- typeCheckOpImpl tcInstr op inputStack       >>= mapMSeq prependStackTypeComment@@ -386,6 +386,7 @@                         (TCUnreachableCode (extractOpPos op) (op :| ops))                         (map NonTypedInstr ops)) +    combine inp Nop (_ :/ nextPart) = inp :/ nextPart     combine inp i1 (_ :/ nextPart) = inp :/ mapSomeInstrOut (Seq i1) nextPart      extractOpPos :: Un.ExpandedOp -> InstrCallStack@@ -482,7 +483,7 @@   => Notes t1 -> Notes t2 -> Either TCTypeError (t1 :~: t2, Notes t1) matchTypes n1 n2 = do   Refl <- eqType @t1 @t2-  nr <- converge n1 n2 `onLeft` AnnError+  nr <- converge n1 n2 `onFirst` AnnError   return (Refl, nr)  --------------------------------------------@@ -747,7 +748,7 @@   _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $     NotNumericTypes (demote @a) (demote @b) --- | Helper function to construct instructions for binary arithmetic+-- | Helper function to construct instructions for unary arithmetic -- operations. unaryArithImpl   :: ( Typeable (UnaryArithRes aop n ': s)@@ -761,3 +762,19 @@   -> t (SomeInstr inp) unaryArithImpl mkInstr i@(_ ::& rs) vn = do   pure $ i :/ mkInstr ::: ((starNotes, Dict, vn) ::& rs)++-- | Helper function to construct instructions for unary arithmetic+-- operations that should preserve annotations.+unaryArithImplAnnotated+  :: ( Typeable (UnaryArithRes aop n ': s)+     , WellTyped (UnaryArithRes aop n)+     , inp ~ (n ': s)+     , Monad t+     , n ~ UnaryArithRes aop n+     )+  => Instr inp (UnaryArithRes aop n ': s)+  -> HST inp+  -> VarAnn+  -> t (SomeInstr inp)+unaryArithImplAnnotated mkInstr i@((n, _, _) ::& rs) vn = do+  pure $ i :/ mkInstr ::: ((n, Dict, vn) ::& rs)
src/Michelson/TypeCheck/Instr.hs view
@@ -62,6 +62,7 @@  import Michelson.Typed import Util.Peano+import Util.Type (onFirst)  import qualified Michelson.Untyped as U import Michelson.Untyped.Annotation (VarAnn)@@ -160,7 +161,7 @@             (NTPair _ _ _ cpNotes stNotes, _, _) ::& SNil -> (cpNotes, stNotes)       cParamNotes <-         liftEither $-        mkParamNotes paramNotesRaw rootAnn `onLeft`+        mkParamNotes paramNotesRaw rootAnn `onFirst`             (TCContractError "invalid parameter declaration: " . Just . IllegalParamDecl)       case instrOut of         instr ::: out -> liftEither $ do@@ -168,7 +169,7 @@             Right Refl -> do               let (outN, _, _) ::& SNil = out               _ <- converge outN outNote-                      `onLeft`+                      `onFirst`                   ((TCContractError "contract output type violates convention:") . Just . AnnError)               pure $ SomeContract Contract                 { cCode = instr@@ -705,16 +706,20 @@       withWTPInstr' @u $         lamImpl (U.LAMBDA vn p1 p2) uInstr is vn ins ons i -  (U.EXEC vn, ((_ :: Notes t1), _, _)+  (U.EXEC vn, ((tn :: Notes t1), _, _)                               ::& ( STLambda _ _-                                  , NTLambda _ (_ :: Notes t1') (t2n :: Notes t2')+                                  , NTLambda _ (t1n :: Notes t1') (t2n :: Notes t2')                                   , _                                   , _                                   )                               ::&+ rs) -> workOnInstr uInstr $ do     Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument)                   (eqType @t1 @t1')+    (Refl, _) <- errM $ matchTypes tn t1n     withWTPInstr @t2' $ pure $ inp :/ EXEC ::: ((t2n, Dict, vn) ::& rs)+      where+        errM :: (MonadReader InstrCallStack m, MonadError TCError m) => Either TCTypeError a -> m a+        errM = onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument)    (U.EXEC _, _ ::& _ ::& _) ->     failWithErr $ UnexpectedType@@ -888,7 +893,7 @@     (U.ABS _, SNil) -> notEnoughItemsOnStack      (U.NEG vn, (STInt, _, _, _) ::&+ _) -> workOnInstr uInstr $-      unaryArithImpl @Neg NEG inp vn+      unaryArithImplAnnotated @Neg NEG inp vn     (U.NEG vn, (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $       unaryArithImpl @Neg NEG inp vn     (U.NEG _, _ ::& _) ->@@ -958,9 +963,9 @@     (U.NOT vn, (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $       unaryArithImpl @Not NOT inp vn     (U.NOT vn, (STBool, _, _, _) ::&+ _) -> workOnInstr uInstr $-      unaryArithImpl @Not NOT inp vn+      unaryArithImplAnnotated @Not NOT inp vn     (U.NOT vn, (STInt, _, _, _) ::&+ _) -> workOnInstr uInstr $-      unaryArithImpl @Not NOT inp vn+      unaryArithImplAnnotated @Not NOT inp vn     (U.NOT _, _ ::& _) ->       failWithErr $ UnexpectedType         $ (ExpectNat :| []) :|@@ -1060,7 +1065,7 @@           $ checkScope @(ParameterScope t)         let ns = NTOption def $ NTContract def tns         epName <- onTypeCheckInstrErr uInstr (SomeHST inp) Nothing-          $ epNameFromRefAnn fn `onLeft` IllegalEntrypoint+          $ epNameFromRefAnn fn `onFirst` IllegalEntrypoint         case proofScope of           Dict ->             withWTPInstr @t $ pure $ inp :/ CONTRACT tns epName ::: ((ns, Dict, vn) ::& rs)
src/Michelson/TypeCheck/Value.hs view
@@ -29,6 +29,7 @@ import Tezos.Address (Address(..)) import Tezos.Core import Tezos.Crypto+import Util.Type (onFirst)  tcFailedOnValue :: U.Value -> T.T -> Text -> Maybe TCTypeError -> TypeCheckInstr a tcFailedOnValue v t msg err = do@@ -147,7 +148,7 @@          els <- typeCheckValsImpl mels         elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc id els-                  `onLeft` \msg -> TCFailedOnValue sq (fromSingT vt) msg instrPos Nothing+                  `onFirst` \msg -> TCFailedOnValue sq (fromSingT vt) msg instrPos Nothing         pure $ VSet elsS        (v@U.ValueNil, s@(STMap (st :: Sing st) _)) -> withComparable st v s $ pure $ T.VMap M.empty@@ -216,7 +217,7 @@       ks <- typeCheckValsImpl @kt (map (\(U.Elt k _) -> k) mels)       vals <- typeCheckValsImpl @vt (map (\(U.Elt _ v) -> v) mels)       ksS <- liftEither $ ensureDistinctAsc id ks-            `onLeft` \msg -> TCFailedOnValue sq (fromSingT kt) msg instrPos Nothing+            `onFirst` \msg -> TCFailedOnValue sq (fromSingT kt) msg instrPos Nothing       pure $ zip ksS vals      typecheckContractValue
src/Michelson/Typed/Doc.hs view
@@ -2,6 +2,8 @@ -- -- SPDX-License-Identifier: LicenseRef-MIT-TQ +{-# OPTIONS_GHC -Wno-orphans #-}+ -- | Extracting documentation from instructions set. module Michelson.Typed.Doc   ( buildInstrDoc@@ -54,26 +56,20 @@ docInstr :: DocItem di => di -> Instr s s docInstr = Ext . DOC_ITEM . SomeDocItem -attachGitInfo :: DGitRevision -> Instr inp out -> Instr inp out-attachGitInfo gitRev = modifyInstrDoc $ \case-  DGitRevisionUnknown -> Just gitRev-  _ -> Nothing--attachToc :: DToc -> Instr inp out -> Instr inp out-attachToc toc = modifyInstrDoc $ \case-  DToc "" -> Just $ toc-  _ -> Nothing- -- | Assemble contract documentation with the revision of the contract.+{-# DEPRECATED buildInstrDocWithGitRev+    "Use `buildDoc . attachDocCommons gitRev` instead."+#-} buildInstrDocWithGitRev :: DGitRevision -> Instr inp out -> ContractDoc buildInstrDocWithGitRev gitRev contract =   let toc = DToc $ contractDocToToc $ buildInstrDoc contract-      c = contract-            & attachGitInfo gitRev-            & attachToc toc-  in buildInstrDoc c+      c = pure contract+            >>= attachGitInfo gitRev+            >>= attachToc toc+  in buildDoc c  -- | Assemble contract documentation.+{-# DEPRECATED buildInstrDoc "Use 'buildDoc' instead." #-} buildInstrDoc :: Instr inp out -> ContractDoc buildInstrDoc = dfsFoldInstr dfsSettings $ \case   Ext ext -> case ext of@@ -94,6 +90,7 @@     }  -- | Modify all documentation items recursively.+{-# DEPRECATED modifyInstrAllDoc "Use 'modifyDocEntirely' instead." #-} modifyInstrAllDoc   :: (SomeDocItem -> SomeDocItem)   -> Instr inp out@@ -109,6 +106,7 @@ -- matching given type. -- -- If mapper returns 'Nothing', doc item will remain unmodified.+{-# DEPRECATED modifyInstrDoc "Use 'modifyDoc' instead." #-} modifyInstrDoc   :: (DocItem i1, DocItem i2)   => (i1 -> Maybe i2)@@ -120,6 +118,12 @@     di' <- cast di     newDi <- mapper di'     return (SomeDocItem newDi)++instance ContainsDoc (Instr inp out) where+  buildDocUnfinalized = buildInstrDoc++instance ContainsUpdateableDoc (Instr inp out) where+  modifyDocEntirely = modifyInstrAllDoc  -- | Leave only instructions related to documentation. --
src/Michelson/Typed/Haskell.hs view
@@ -7,6 +7,7 @@   ( module Exports   ) where +import Michelson.Typed.Haskell.Compatibility as Exports import Michelson.Typed.Haskell.Doc as Exports import Michelson.Typed.Haskell.Instr as Exports import Michelson.Typed.Haskell.LooseSum as Exports
+ src/Michelson/Typed/Haskell/Compatibility.hs view
@@ -0,0 +1,40 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Compatibility of Haskell values representation in Michelson.+module Michelson.Typed.Haskell.Compatibility+  ( ligoLayout+  , ligoCombLayout+  ) where++import Util.CustomGeneric++-- | Default layout in LIGO.+--+-- To be used with 'customGeneric', see this method for more info.+--+-- This is similar to 'leftBalanced', but+--+-- * fields are sorted alphabetically;+-- * always puts as large complete binary subtrees as possible at left.+ligoLayout :: GenericStrategy+ligoLayout =+  reorderingData forbidUnnamedFields alphabetically $+    fromDepthsStrategy ligoDepths+  where+    ligoDepths n =+      case fmap last . nonEmpty $ takeWhile (\(_, p) -> p <= n) powersOfTwo of+        Nothing -> []+        Just (depth, power) ->+          let leftSub = replicate power depth+              rightSub = ligoDepths (n - power)+          in if null rightSub then leftSub else map succ $ leftSub ++ rightSub++    powersOfTwo = [0..] <&> \i -> (i, 2 ^ i)++-- | Comb layout in LIGO (@ [\@layout:comb] @).+--+-- To be used with 'customGeneric'.+ligoCombLayout :: GenericStrategy+ligoCombLayout = rightComb
src/Michelson/Typed/Haskell/Doc.hs view
@@ -39,6 +39,7 @@    , DType (..)   , DStorageType (..)+  , dStorage   , GTypeHasDoc   , GProductHasDoc   , dTypeDep@@ -105,7 +106,7 @@ -- | Show given 'ADTRep' in a neat way. buildADTRep :: forall a. (WithinParens -> a -> Markdown) -> ADTRep a -> Markdown buildADTRep buildField = \case-  ConstructorRep{..} :| [] -> renderProduct (WithinParens False) crFields+  ctor@ConstructorRep{..} :| [] -> renderProduct (WithinParens False) ctor crFields   ps -> (mappend (mdItalic "one of" <> " \n")) $         foldMap         (toListItem . renderNamedProduct (WithinParens True)) (toList ps)@@ -113,26 +114,29 @@     toListItem item = "+ " <> item <> "\n"      renderNamedProduct :: WithinParens -> ConstructorRep a -> Markdown-    renderNamedProduct wp ConstructorRep{..} =+    renderNamedProduct wp ctor@ConstructorRep{..} =       mdBold (build crName) <>       if hasFieldNames-         then maybe "" (\d -> ": " <> build d <> " ") crDescription <> renderProduct wp crFields-         else renderProduct wp crFields <> maybe "" (\d -> ": " <> build d) crDescription+         then maybe "" (\d -> ": " <> build d <> " ") crDescription <>+              renderProduct wp ctor crFields+         else renderProduct wp ctor crFields <>+              maybe "" (\d -> ": " <> build d) crDescription       where         hasFieldNames = any (isJust . frName) crFields -    renderProduct :: WithinParens -> [FieldRep a] -> Markdown-    renderProduct wp = \case+    renderProduct :: WithinParens -> ConstructorRep a -> [FieldRep a] -> Markdown+    renderProduct wp ctor = \case       [] -> "()"-      [t] -> "\n" <> renderNamedField wp t-      ts -> "\n" <> (mconcat . intersperse "\n" $ map (renderNamedField wp) ts)+      [t@FieldRep{ frDescription = Nothing }]+        | Nothing <- crDescription ctor -> renderNamedField wp t+      ts -> mconcat $ map (("\n  * " <>) . renderNamedField wp) ts      renderNamedField :: WithinParens -> FieldRep a -> Markdown-    renderNamedField wp FieldRep{frName = Just fieldName, ..} =-      "  * " <> buildFieldName fieldName <> buildField wp frTypeRep <>-      maybe "" (mappend "    " . mappend "\n" . build) frDescription--    renderNamedField wp FieldRep{frName = Nothing, ..} = buildField wp frTypeRep+    renderNamedField wp FieldRep{..} = mconcat+      [ maybe "" buildFieldName frName+      , buildField wp frTypeRep+      , maybe "" (mappend "    " . mappend "\n" . build) frDescription+      ]  -- | Map field names in a 'ADTRep', with the possibility to remove some names by -- mapping them to 'Nothing'.@@ -377,6 +381,10 @@ -- | Doc element with description of contract storage type. newtype DStorageType = DStorageType DType   deriving stock (Generic, Eq, Ord)++-- | Shortcut for 'DStorageType'.+dStorage :: forall store. TypeHasDoc store => DStorageType+dStorage = DStorageType $ DType (Proxy @store)  instance DocItem DStorageType where   type DocItemPlacement DStorageType = 'DocItemInlined
src/Michelson/Typed/Instr.hs view
@@ -16,6 +16,7 @@   , TestAssert (..)   , ContractCode   , Contract (..)+  , defaultContract   , mapContractCode   , mapEntriesOrdered   , pattern CAR@@ -31,6 +32,7 @@   , ConstraintDUG'   ) where +import Data.Default import Data.Singletons (Sing) import Fmt (Buildable(..), (+||), (||+)) import qualified GHC.TypeNats as GHC (Nat)@@ -39,7 +41,7 @@ import Michelson.Doc import Michelson.ErrorPos import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, needsParens, printDocS)-import Michelson.Typed.Annotation (Notes(..))+import Michelson.Typed.Annotation (Notes(..), starNotes) import Michelson.Typed.Arith import Michelson.Typed.Entrypoints import Michelson.Typed.Polymorphic@@ -476,6 +478,14 @@ deriving stock instance Eq (ContractCode cp st) => Eq (Contract cp st) instance NFData (Contract cp st) where   rnf (Contract a b c d) = rnf (a, b, c, d)++defaultContract :: (ParameterScope cp, StorageScope st) => ContractCode cp st -> Contract cp st+defaultContract code = Contract+  { cCode = code+  , cParamNotes = starParamNotes+  , cStoreNotes = starNotes+  , cEntriesOrder = def+  }  mapContractCode   :: (ContractCode cp st -> ContractCode cp st)
src/Michelson/Typed/Util.hs view
@@ -144,6 +144,8 @@       | otherwise -> step i      Nop{} -> step i+    Ext (TEST_ASSERT (TestAssert nm pc i1)) ->+      recursion1 (Ext . TEST_ASSERT . TestAssert nm pc) i1     Ext{} -> step i     AnnCAR{} -> step i     AnnCDR{} -> step i
src/Michelson/Untyped/Instr.hs view
@@ -126,7 +126,7 @@   | RIGHT             TypeAnn VarAnn FieldAnn FieldAnn Type   | IF_LEFT           [op] [op]   | NIL               TypeAnn VarAnn Type-  | CONS              VarAnn -- TODO add TypeNote param+  | CONS              VarAnn   | IF_CONS           [op] [op]   | SIZE              VarAnn   | EMPTY_SET         TypeAnn VarAnn Type@@ -141,7 +141,6 @@   | LOOP              [op]   | LOOP_LEFT         [op]   | LAMBDA            VarAnn Type Type [op]-  -- TODO check on alphanet whether we can pass TypeNote   | EXEC              VarAnn   | APPLY             VarAnn   | DIP               [op]
src/Morley/Micheline/Expression.hs view
@@ -16,11 +16,13 @@   , annotFromText   ) where +import Control.Lens (Plated) import Data.Aeson   (FromJSON, ToJSON, object, parseJSON, toEncoding, toJSON, withObject, withText, (.!=), (.:),   (.:?), (.=)) import qualified Data.Aeson.Encoding.Internal as Aeson import qualified Data.Aeson.Types as Aeson+import Data.Data (Data) import qualified Data.HashMap.Strict as HashMap import qualified Data.Sequence as Seq import qualified Data.Text as T (uncons)@@ -29,13 +31,13 @@ import Michelson.Untyped.Annotation   (FieldAnn, FieldTag, KnownAnnTag(..), TypeAnn, TypeTag, VarAnn, VarTag, ann, annPrefix) import qualified Michelson.Untyped.Annotation as MUA (Annotation)-import Morley.Micheline.Json+import Morley.Micheline.Json (StringEncode(StringEncode, unStringEncode)) import Tezos.Crypto (encodeBase58Check) import Util.ByteString (HexJSONByteString(..))  newtype MichelinePrimitive = MichelinePrimitive Text   deriving newtype (Eq, Ord, ToJSON, FromJSON)-  deriving stock (Show)+  deriving stock (Show, Data)  michelsonPrimitive :: Seq Text michelsonPrimitive = Seq.fromList [@@ -69,8 +71,10 @@   | ExpressionBytes ByteString   | ExpressionSeq (Seq Expression)   | ExpressionPrim MichelinePrimAp-  deriving stock (Eq, Show)+  deriving stock (Eq, Show, Data) +instance Plated Expression+ instance Buildable Expression where   build = \case     ExpressionInt i -> build $ i@@ -91,13 +95,13 @@   = AnnotationType TypeAnn   | AnnotationVariable VarAnn   | AnnotationField FieldAnn-  deriving stock (Eq, Show)+  deriving stock (Eq, Show, Data)  data MichelinePrimAp = MichelinePrimAp   { mpaPrim :: MichelinePrimitive   , mpaArgs :: Seq Expression   , mpaAnnots :: Seq Annotation-  } deriving stock (Eq, Show)+  } deriving stock (Eq, Show, Data)  instance FromJSON MichelinePrimAp where   parseJSON = withObject "Prim" $ \v -> MichelinePrimAp
src/Morley/Micheline/Json.hs view
@@ -20,8 +20,11 @@ import Fmt (Buildable(..)) import qualified Text.Show as T -import Tezos.Core (Mutez, mkMutez')+import Tezos.Core (Mutez, mkMutez', mutezToInt64) +printAsString :: Show a => a -> Aeson.Value+printAsString a = Aeson.String $ show a+ parseAsString :: forall a. (Read a, Typeable a) => Aeson.Value -> Aeson.Parser a parseAsString = Aeson.withText (T.show $ typeRep (Proxy :: Proxy a)) $ \txt ->   maybe (fail "Failed to parse string") pure $ readMaybe (toString txt)@@ -55,9 +58,12 @@   toEncoding (StringEncode x) = AE.int64Text x  newtype TezosMutez = TezosMutez { unTezosMutez :: Mutez }-  deriving stock (Show)+  deriving stock (Show, Eq, Ord) +instance ToJSON TezosMutez where+  toJSON = printAsString . mutezToInt64 . unTezosMutez+ instance FromJSON TezosMutez where   parseJSON v = do-    StringEncode i <- parseStringEncodedIntegral @Int64 v+    i <- parseAsString @Int64 v     either (fail . toString) (pure . TezosMutez) $ mkMutez' i
src/Tezos/Core.hs view
@@ -19,6 +19,7 @@   , mulMutez   , divModMutez   , divModMutezInt+  , mutezToInt64   , zeroMutez   , oneMutez   , prettyTez@@ -175,6 +176,12 @@   where     toMutez' :: Integer -> Mutez     toMutez' = Mutez . fromInteger++-- | Convert mutez to signed number.+--+-- TODO [#423]: try to provide a generic safe conversion method+mutezToInt64 :: Mutez -> Int64+mutezToInt64 = fromIntegral . unMutez  zeroMutez :: Mutez zeroMutez = Mutez minBound
src/Util/CustomGeneric.hs view
@@ -6,21 +6,35 @@  module Util.CustomGeneric   ( -- * Custom Generic strategies-    withDepths+    GenericStrategy+  , withDepths   , rightBalanced   , leftBalanced   , rightComb   , leftComb+  , haskellBalanced+    -- ** Entries reordering+  , reorderingConstrs+  , reorderingFields+  , reorderingData+  , alphabetically+  , leaveUnnamedFields+  , forbidUnnamedFields     -- * Depth usage helpers   , cstr   , fld     -- * Instance derivation   , customGeneric++    -- * Helpers+  , fromDepthsStrategy   ) where -import qualified GHC.Generics as G+import Control.Lens (traversed) import Generics.Deriving.TH (makeRep0Inline)+import qualified GHC.Generics as G import Language.Haskell.TH+import Util.Generic  ---------------------------------------------------------------------------- -- Simple type synonyms@@ -37,25 +51,58 @@ -- of fields. Used only in this module. type CstrShape = (Name, Int) --- | Type of a strategy to derive 'G.Generic' instances, it will be given the actual--- 'CstrShape's for a data-type and needs to return the 'CstrDepth's for it.--- It should when possible make checks and 'fail', using the constructors' 'Name'--- provided by the 'CstrShape'.-type GenericStrategy = [CstrShape] -> Q [CstrDepth]+-- | Simple tuple that carries basic info about a constructor: it's name,+-- number of its fields and their names. Used only in this module.+type CstrNames = (Name, Int, Maybe [Name]) +-- | Type of a strategy to derive 'G.Generic' instances.+data GenericStrategy = GenericStrategy+  { gsEvalDepths :: [CstrShape] -> Q [CstrDepth]+    -- ^ Given the 'CstrShape's for given datatype,+    -- return the 'CstrDepth's for it.+    -- This function should when possible make checks and 'fail', using the+    -- constructors' 'Name' provided by the 'CstrShape'.+  , gsReorderCstrsOn :: forall a. [(Text, a)] -> Q [a]+    -- ^ Reorder constructors given their names.+  , gsReorderFieldsOn :: forall a. Either [a] [(Text, a)] -> Q [a]+    -- ^ Reorder fields given their names, the argument depends on whether+    -- fields are part of record (and thus named) or not (unnamed).+  }++-- | Defines how to reorder fields or constructors.+type EntriesReorder = forall a. [(Text, a)] -> Q [a]++-- | Defines how to reorder fields when their names are unknown.+type UnnamedEntriesReorder = forall a. [a] -> Q [a]+ -- | Simple type synonym used (internally) between functions, basically extending -- 'CstrDepth' with the 'Name's of the constructor and its fields.-type NamedCstrDepths = (Natural, Name, [(Natural, Name)])+-- For fields it carries both names in the original order and in the order specified+-- by the strategy (and the latter is paired with depths).+data NamedCstrDepths = NCD+  { ncdCstrDepth :: Natural+    -- ^ Constructor's depth+  , ncdCstrName :: Name+    -- ^ Constructor's name+  , ncdOrigFieldNames :: [Name]+    -- ^ Names of constructor fields in the original order.+  , ncdFields :: [(Natural, Name)]+    -- ^ Names and depths of constructor fields after the reordering.+  } +-- | Reorders entries corresponding to constructors (@a@) and fields (@b@)+-- according to some rule.+type EntriesTransp = forall a b. [a] -> Q [([b] -> Q [b], a)]+ ------------------------------------------------------------------------------- Custom Generic strategies+-- Generic strategies ----------------------------------------------------------------------------  -- | In this strategy the desired depths of contructors (in the type tree) and -- fields (in each constructor's tree) are provided manually and simply checked -- against the number of actual constructors and fields. withDepths :: [CstrDepth] -> GenericStrategy-withDepths treeDepths cstrShape = do+withDepths treeDepths = simpleGenericStrategy $ \cstrShape -> do   when (length treeDepths /= length cstrShape) $ fail     "Number of contructors' depths does not match number of data contructors."   forM_ (zip (map snd treeDepths) cstrShape) $ \(fDepths, (constrName, fldNum)) ->@@ -65,10 +112,17 @@   return treeDepths  -- | Strategy to make right-balanced instances (both in constructors and fields).+--+-- This will try its best to produce a flat tree:+--+-- * the balances of all leaves differ no more than by 1;+-- * leaves at left will have equal or lesser depth than leaves at right. rightBalanced :: GenericStrategy rightBalanced = fromDepthsStrategy makeRightBalDepths  -- | Strategy to make left-balanced instances (both in constructors and fields).+--+-- This is the same as symmetrically mapped 'rightBalanced'. leftBalanced :: GenericStrategy leftBalanced = fromDepthsStrategy (reverse . makeRightBalDepths) @@ -80,15 +134,99 @@ leftComb :: GenericStrategy leftComb = fromDepthsStrategy makeLeftCombDepths +-- | Strategy to make Haskell's Generics-like instances+-- (both in constructors and fields).+--+-- This is similar to 'rightBalanced', except for the "flat" part:+--+-- * for each node, size of the left subtree is equal or less by one than+-- size of the right subtree.+--+-- This strategy matches A1.1.+--+-- @customGeneric "T" haskellBalanced@ is equivalent to mere+-- @deriving stock Generic T@.+haskellBalanced :: GenericStrategy+haskellBalanced = fromDepthsStrategy makeHaskellDepths++-- Order modifiers ----------------------------------------------------------------------------++-- | Modify given strategy to reorder constructors.+--+-- The reordering will take place before depths are evaluated and structure+-- of generic representation is formed.+--+-- Example: @reorderingConstrs alphabetically rightBalanced@.+reorderingConstrs :: EntriesReorder -> GenericStrategy -> GenericStrategy+reorderingConstrs reorder gs = gs+  { gsReorderCstrsOn = reorder+  }++-- | Modify given strategy to reorder fields.+--+-- Same notes as for 'reorderingConstrs' apply here.+--+-- Example: @reorderingFields forbidUnnamedFields alphabetically rightBalanced@.+reorderingFields+  :: UnnamedEntriesReorder+  -> EntriesReorder+  -> GenericStrategy -> GenericStrategy+reorderingFields reorderUnnamed reorder gs = gs+  { gsReorderFieldsOn = either reorderUnnamed reorder+  }++-- | Modify given strategy to reorder constructors and fields.+--+-- Same notes as for 'reorderingConstrs' apply here.+--+-- Example: @reorderingData forbidUnnamedFields alphabetically rightBalanced@.+reorderingData+  :: UnnamedEntriesReorder+  -> EntriesReorder+  -> GenericStrategy -> GenericStrategy+reorderingData reorderUnnamed reorder =+  reorderingFields reorderUnnamed reorder . reorderingConstrs reorder++-- | Sort entries by name alphabetically.+alphabetically :: EntriesReorder+alphabetically = pure . map snd . sortWith fst++-- | Leave unnamed fields intact, without any reordering.+leaveUnnamedFields :: UnnamedEntriesReorder+leaveUnnamedFields = pure++-- | Fail in case records are unnamed and we cannot figure+-- out the necessary reordering.+forbidUnnamedFields :: UnnamedEntriesReorder+forbidUnnamedFields fields =+  if length fields <= 1+  then return fields+  else fail "Encountered unnamed fields, cannot apply reordering"++---------------------------------------------------------------------------- -- Generic strategies' builders ---------------------------------------------------------------------------- +-- | Construct a strategy that only constructs Generic instance of given+-- form, without e.g. changing the order of entries.+simpleGenericStrategy :: ([CstrShape] -> Q [CstrDepth]) -> GenericStrategy+simpleGenericStrategy mkDepths = GenericStrategy+  { gsEvalDepths = mkDepths+  , gsReorderCstrsOn = pure . map snd+  , gsReorderFieldsOn = pure . either id (map snd)+  }+ -- | Helper to make a strategy that created depths for constructor and fields -- in the same way, just from their number.+--+-- The provided function @f@ must satisfy the following rules:+--+-- * @length (f n) ≡ n@+-- * @sum $ (\x -> 2 ^^ (-x)) <$> f n ≡ 1@ (unless @n = 0@) fromDepthsStrategy :: (Int -> [Natural]) -> GenericStrategy-fromDepthsStrategy dStrategy cShapes = return $-  zip (dStrategy $ length cShapes) $ map (dStrategy . snd) cShapes+fromDepthsStrategy dStrategy = simpleGenericStrategy $ \cShapes -> return $+  zip (dStrategy $ length cShapes) $ map (dStrategy . view _2) cShapes  makeRightBalDepths :: Int -> [Natural] makeRightBalDepths n = foldr (const addRightBalDepth) [] [1..n]@@ -104,6 +242,12 @@ makeLeftCombDepths 0 = [] makeLeftCombDepths n = map fromIntegral $ (n - 1) : [n - 1, n - 2..1] +makeHaskellDepths :: Int -> [Natural]+makeHaskellDepths n =+  case nonEmpty (replicate n [0]) of+    Nothing -> []+    Just leaves -> mkGenericTree (\_ l r -> map succ (l ++ r)) leaves+ ---------------------------------------------------------------------------- -- Depth usage helpers ----------------------------------------------------------------------------@@ -128,6 +272,8 @@ -- Instance derivation ---------------------------------------------------------------------------- +{-# ANN module ("HLint: ignore Use snd" :: Text) #-}+ -- | Derives the 'G.Generic' instance for a type given its name and a -- 'GenericStrategy' to use. --@@ -177,24 +323,47 @@ -- $(customGeneric "CustomType" leftComb) -- @@@ --+-- Developers are welcome to provide their own derivation strategies,+-- and some useful strategies can be found outside of this module by+-- 'GenericStrategy' signature. customGeneric :: String -> GenericStrategy -> Q [Dec] customGeneric typeStr genStrategy = do   -- reify the data type   (typeName, mKind, vars, constructors) <- reifyDataType typeStr   -- obtain info about its constructor and desired tree   let derivedType = deriveFullType typeName mKind vars-  cShapes <- cstrShapes constructors-  treeDepths <- genStrategy cShapes-  weightedConstrs <- makeWeightedConstrs treeDepths cShapes+  cNames <- cstrNames constructors+  let cReordering :: EntriesTransp+      cReordering = reorderCstrs genStrategy cNames+  let cShapes = cNames <&> \(name, fNum, _) -> (name, fNum)+  cShapesSorted <- cReordering cShapes <&> map \(_fReorder, cShape) -> cShape+  treeDepths <- gsEvalDepths genStrategy cShapesSorted+  weightedConstrs <- makeWeightedConstrs cReordering treeDepths cShapesSorted   -- produce the Generic instance   res <- instanceD (pure []) (appT (conT ''G.Generic) derivedType)     [ tySynInstD . tySynEqn Nothing (appT (conT ''G.Rep) derivedType) $-        makeUnbalancedRep typeName treeDepths derivedType+        makeUnbalancedRep typeName treeDepths cReordering derivedType     , makeUnbalancedFrom weightedConstrs     , makeUnbalancedTo weightedConstrs     ]   return [res] +-- | Apply a reordering strategy.+--+-- This uses given @[CstrNames]@ to understand how constructors and their+-- fields should be reordered, and applies the same transposition to entries+-- within 'EntriesTransp'.+reorderCstrs :: GenericStrategy -> [CstrNames] -> EntriesTransp+reorderCstrs GenericStrategy{..} cNames = \cstrEntries ->+  gsReorderCstrsOn $+    zip cNames cstrEntries <&> \(cstrName@(name, _, _), cstrEntry) ->+      (origName name, (fieldsReorder cstrName, cstrEntry))+  where+    fieldsReorder :: CstrNames -> [b] -> Q [b]+    fieldsReorder (_, _, mFieldNames) = \fieldEntries -> do+      gsReorderFieldsOn $+        maybe Left (Right ... zip . map origName) mFieldNames fieldEntries+ -- | Reifies info from a type name (given as a 'String'). -- The lookup happens from the current splice's scope (see 'lookupTypeName') and -- the only accepted result is a "plain" data type (no GADTs).@@ -223,22 +392,30 @@       PlainTV vName       -> varT vName       KindedTV vName kind -> sigT (varT vName) kind --- | Calculate the "shape" for each of the given constructors.--- The shape is simply the 'Name' of the constructor and the number of its args.-cstrShapes :: [Con] -> Q [CstrShape]-cstrShapes constructors = forM constructors $ \case-  NormalC name lst -> return (name, length lst)-  RecC name lst    -> return (name, length lst)-  InfixC _ name _  -> return (name, 2)+-- | Extract the info for each of the given constructors.+cstrNames :: [Con] -> Q [CstrNames]+cstrNames constructors = forM constructors $ \case+  NormalC name lst -> return (name, length lst, Nothing)+  RecC name lst    -> return (name, length lst, Just $ lst ^.. traversed . _1)+  InfixC _ name _  -> return (name, 2, Nothing)   constr           -> fail $ "Unsupported constructor: " <> show constr  -- | Combines depths with constructors, 'fail'ing in case of mismatches, and -- generates 'Name's for the constructors' arguments.-makeWeightedConstrs :: [CstrDepth] -> [CstrShape] -> Q [NamedCstrDepths]-makeWeightedConstrs treeDepths cSizes = do-  forM (zip treeDepths cSizes) $ \((cDepth, fDepths), (cName, fNum)) -> do-    constrVarsNames <- replicateM fNum $ newName "v"-    return (cDepth, cName, zip fDepths constrVarsNames)+makeWeightedConstrs+  :: EntriesTransp -> [CstrDepth] -> [CstrShape] -> Q [NamedCstrDepths]+makeWeightedConstrs cReorder treeDepths cShapes = do+  reorderedShapes <- cReorder cShapes+  forM (zip treeDepths reorderedShapes) $+    \((cDepth, fDepths), (fReorder, (cName, fNum))) -> do+      fieldVarsNames <- replicateM fNum (newName "v")+      reorderedFieldVarNames <- fReorder fieldVarsNames+      return NCD+        { ncdCstrDepth = cDepth+        , ncdCstrName = cName+        , ncdOrigFieldNames = fieldVarsNames+        , ncdFields = zip fDepths reorderedFieldVarNames+        }  -- | Creates the 'G.Rep' type for an unbalanced 'G.Generic' instance, for a type -- given its name, constructors' depths and derived full type.@@ -246,23 +423,27 @@ -- Note: given that these types definition can be very complex to generate, -- especially in the metadata, here we let @generic-deriving@ make a balanced -- value first (see 'makeRep0Inline') and then de-balance the result.-makeUnbalancedRep :: Name -> [CstrDepth] -> TypeQ -> TypeQ-makeUnbalancedRep typeName treeDepths derivedType = do+makeUnbalancedRep :: Name -> [CstrDepth] -> EntriesTransp -> TypeQ -> TypeQ+makeUnbalancedRep typeName treeDepths reorderConstrs derivedType = do   -- let generic-deriving create the balanced type first   balRep <- makeRep0Inline typeName derivedType   -- separate the top-most type metadata from the constructors' trees   (typeMd, constrTypes) <- dismantleGenericTree [t| (G.:+:) |] [t| G.C1 |] balRep   -- for each of the constructor's trees-  unbalConstrs <- forM (zip constrTypes treeDepths) $ \(constrType, treeDepth) ->+  reorderedConstrTypes <- reorderConstrs constrTypes+  unbalConstrs <- forM (zip reorderedConstrTypes treeDepths) $+    \((reorderFields, constrType), treeDepth) ->     case treeDepth of       (n, []) ->         -- when there are no fields there is no tree to unbalance         return (n, constrType)-      (n, fields) -> do+      (n, fieldDepths) -> do         -- separate the top-most constructor metadata from the fields' trees         (constrMd, fieldTypes) <- dismantleGenericTree [t| (G.:*:) |] [t| G.S1 |] constrType         -- build the unbalanced tree of fields-        unbalConstRes <- unbalancedFold (zip fields fieldTypes) (appT . appT (conT ''(G.:*:)))+        reorderedFieldTypes <- reorderFields fieldTypes+        unbalConstRes <- unbalancedFold (zip fieldDepths reorderedFieldTypes)+                                        (appT . appT (conT ''(G.:*:)))         -- return the new unbalanced constructor         return (n, AppT constrMd unbalConstRes)   -- build the unbalanced tree of constructors and rebuild the type@@ -293,14 +474,13 @@ -- its list of weighted constructors. makeUnbalancedFrom :: [NamedCstrDepths] -> DecQ makeUnbalancedFrom wConstrs = do-  (cPatts, cDepthExp) <- fmap unzip . forM wConstrs $ \(cDepth, cName, wFields) -> do-    (fPatts, fDepthExp) <- fmap unzip . forM wFields $ \(fDepth, fName) -> do-      -- make pattern for field variable-      fPat <- varP fName+  (cPatts, cDepthExp) <- fmap unzip . forM wConstrs $ \(NCD cDepth cName wOrigFields wFields) -> do+    fDepthExp <- forM wFields $ \(fDepth, fName) -> do       -- make expression to asseble a Generic Field from its variable       fExpr <- appE [| G.M1 |] . appE [| G.K1 |] $ varE fName-      return (fPat, (fDepth, fExpr))+      return (fDepth, fExpr)     -- make pattern for this constructor+    fPatts <- mapM varP wOrigFields     let cPatt = ConP cName fPatts     -- make expression to assemble its fields as an isolated Generic Constructor     cExp <- appE [| G.M1 |] $ case fDepthExp of@@ -317,18 +497,17 @@ -- its list of weighted constructors. makeUnbalancedTo :: [NamedCstrDepths] -> DecQ makeUnbalancedTo wConstrs = do-  (cExps, cDepthPat) <- fmap unzip . forM wConstrs $ \(cDepth, cName, wFields) -> do-    (fExps, fDepthPat) <- fmap unzip . forM wFields $ \(fDepth, fName) -> do-      -- make expression for field variable-      fExp <- varE fName+  (cExps, cDepthPat) <- fmap unzip . forM wConstrs $ \(NCD cDepth cName wOrigFields wFields) -> do+    fDepthPat <- forM wFields $ \(fDepth, fName) -> do       -- make pattern for a Generic Field from its variable       fPatt <- conP1 'G.M1 . conP1 'G.K1 $ varP fName-      return (fExp, (fDepth, fPatt))+      return (fDepth, fPatt)     -- make pattern for this isolated Generic Constructor     cPatt <- conP1 'G.M1 $ case fDepthPat of       [] -> conP 'G.U1 []       _  -> unbalancedFold fDepthPat (conP2 '(G.:*:))     -- make expression to assemble this constructor+    fExps <- mapM varE wOrigFields     let cExp = foldl AppE (ConE cName) fExps     return (cExp, (cDepth, [cPatt]))   -- make patterns for all Generic Constructors@@ -379,3 +558,7 @@  mapQ :: (Q a -> Q a) -> Q [a] -> Q [a] mapQ f qlst = qlst >>= mapM (f . pure)++-- | Original name of a constructor or field.+origName :: Name -> Text+origName = toText . nameBase
src/Util/Type.hs view
@@ -36,6 +36,8 @@   , listOfTypesConcatAssociativityAxiom    , MockableConstraint (..)++  , onFirst   ) where  import Data.Constraint ((:-)(..), Dict(..), (\\))@@ -232,3 +234,7 @@     Dict <- pure $ provideConstraintUnsafe @c5     return Dict   {-# INLINE provideConstraintUnsafe #-}++-- | Utility function to help transform the first argument of a binfunctor.+onFirst :: Bifunctor p => p a c -> (a -> b) -> p b c+onFirst = flip first