From 2242f728c43420cb5cfc101a379d2ad265c5a596 Mon Sep 17 00:00:00 2001 From: effectfully Date: Mon, 4 Mar 2024 21:14:35 +0100 Subject: [PATCH 1/2] [AST] Add 'SixList' --- .../src/PlutusCore/Compiler/Erase.hs | 4 +- .../src/UntypedPlutusCore/Core/Instance/Eq.hs | 3 +- .../UntypedPlutusCore/Core/Instance/Flat.hs | 7 +- .../Core/Instance/Pretty/Classic.hs | 3 +- .../Core/Instance/Pretty/Readable.hs | 2 +- .../src/UntypedPlutusCore/Core/Type.hs | 79 ++++++++++++++++++- .../Evaluation/Machine/Cek/Internal.hs | 6 +- .../Machine/SteppableCek/Internal.hs | 5 +- .../src/UntypedPlutusCore/Parser.hs | 3 +- .../UntypedPlutusCore/Transform/CaseReduce.hs | 5 +- plutus-metatheory/src/Untyped.hs | 6 +- 11 files changed, 101 insertions(+), 22 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Compiler/Erase.hs b/plutus-core/plutus-core/src/PlutusCore/Compiler/Erase.hs index 7ad66c48847..fb0d170ad40 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Compiler/Erase.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Compiler/Erase.hs @@ -3,6 +3,8 @@ module PlutusCore.Compiler.Erase (eraseTerm, eraseProgram) where import PlutusCore.Core import UntypedPlutusCore.Core qualified as UPLC +import GHC.Exts (fromList) + -- | Erase a Typed Plutus Core term to its untyped counterpart. eraseTerm :: Term tyname name uni fun ann -> UPLC.Term name uni fun ann eraseTerm (Var ann name) = UPLC.Var ann name @@ -16,7 +18,7 @@ eraseTerm (Unwrap _ term) = eraseTerm term eraseTerm (IWrap _ _ _ term) = eraseTerm term eraseTerm (Error ann _) = UPLC.Error ann eraseTerm (Constr ann _ i args) = UPLC.Constr ann i (fmap eraseTerm args) -eraseTerm (Case ann _ arg cs) = UPLC.Case ann (eraseTerm arg) (fmap eraseTerm cs) +eraseTerm (Case ann _ arg cs) = UPLC.Case ann (eraseTerm arg) (fromList $ fmap eraseTerm cs) eraseProgram :: Program tyname name uni fun ann -> UPLC.Program name uni fun ann eraseProgram (Program a v t) = UPLC.Program a v $ eraseTerm t diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Eq.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Eq.hs index 380ea9f8100..16fb618086c 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Eq.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Eq.hs @@ -2,6 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -100,7 +101,7 @@ eqTermM (Constr ann1 i1 args1) (Constr ann2 i2 args2) = do eqTermM (Case ann1 a1 cs1) (Case ann2 a2 cs2) = do eqM ann1 ann2 eqTermM a1 a2 - case zipExact cs1 cs2 of + case zipExact (toList cs1) (toList cs2) of Just ps -> for_ ps $ \(t1, t2) -> eqTermM t1 t2 Nothing -> empty eqTermM Constant{} _ = empty diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs index fe4b4b2a44e..deef177eaf6 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs @@ -17,6 +17,7 @@ import Data.Word (Word8) import Flat import Flat.Decoder import Flat.Encoder +import GHC.Exts (fromList, toList) import Prettyprinter import Universe @@ -128,7 +129,7 @@ encodeTerm = \case Error ann -> encodeTermTag 6 <> encode ann Builtin ann bn -> encodeTermTag 7 <> encode ann <> encode bn Constr ann i es -> encodeTermTag 8 <> encode ann <> encode i <> encodeListWith encodeTerm es - Case ann arg cs -> encodeTermTag 9 <> encode ann <> encodeTerm arg <> encodeListWith encodeTerm cs + Case ann arg cs -> encodeTermTag 9 <> encode ann <> encodeTerm arg <> encodeListWith encodeTerm (toList cs) decodeTerm :: forall name uni fun ann @@ -165,7 +166,7 @@ decodeTerm version builtinPred = go Constr <$> decode <*> decode <*> decodeListWith go handleTerm 9 = do unless (version >= PLC.plcVersion110) $ fail $ "'case' is not allowed before version 1.1.0, this program has version: " ++ (show $ pretty version) - Case <$> decode <*> go <*> decodeListWith go + Case <$> decode <*> go <*> (fromList <$> decodeListWith go) handleTerm t = fail $ "Unknown term constructor tag: " ++ show t sizeTerm @@ -193,7 +194,7 @@ sizeTerm tm sz = Error ann -> size ann sz' Builtin ann bn -> size ann $ size bn sz' Constr ann i es -> size ann $ size i $ sizeListWith sizeTerm es sz' - Case ann arg cs -> size ann $ sizeTerm arg $ sizeListWith sizeTerm cs sz' + Case ann arg cs -> size ann $ sizeTerm arg $ sizeListWith sizeTerm (toList cs) sz' -- | An encoder for programs. -- diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs index 5b7f9218908..04759e9da5c 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs @@ -48,7 +48,8 @@ instance (PrettyClassicBy configName name, PrettyUni uni, Pretty fun, Pretty ann Constr ann i es -> sexp "constr" (consAnnIf config ann (pretty i : fmap (prettyBy config) es)) Case ann arg cs -> - sexp "case" (consAnnIf config ann (prettyBy config arg : fmap (prettyBy config) cs)) + sexp "case" . consAnnIf config ann $ + prettyBy config arg : fmap (prettyBy config) (toList cs) where prettyTypeOf :: Some (ValueOf uni) -> Doc dann prettyTypeOf (Some (ValueOf uni _ )) = prettyBy juxtRenderContext $ SomeTypeIn uni diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs index a9dc1562225..e0ea87cba05 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs @@ -51,7 +51,7 @@ instance -- Always rendering the tag on the same line for more compact output, it's just a tiny integer -- anyway. Constr _ i es -> iterAppDocM $ \_ prettyArg -> ("constr" <+> prettyArg i) :| [prettyArg es] - Case _ arg cs -> iterAppDocM $ \_ prettyArg -> "case" :| [prettyArg arg, prettyArg cs] + Case _ arg cs -> iterAppDocM $ \_ prettyArg -> "case" :| [prettyArg arg, prettyArg (toList cs)] instance (PrettyReadableBy configName (Term name uni fun a)) => diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs index 10ef656dcec..f1a4f071aa7 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs @@ -1,7 +1,9 @@ -- editorconfig-checker-disable-file +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -13,6 +15,8 @@ module UntypedPlutusCore.Core.Type , TPLC.Binder (..) , Term (..) , Program (..) + , SixList (..) + , lookupSixList , progAnn , progVer , progTerm @@ -28,7 +32,9 @@ module UntypedPlutusCore.Core.Type import Control.Lens import PlutusPrelude +import Data.Hashable import Data.Word +import GHC.Exts as Exts (IsList (..), inline) import PlutusCore.Builtin qualified as TPLC import PlutusCore.Core qualified as TPLC import PlutusCore.MkPlc @@ -85,9 +91,78 @@ data Term name uni fun ann -- TODO: try spine-strict list or strict list or vector -- See Note [Constr tag type] | Constr !ann !Word64 ![Term name uni fun ann] - | Case !ann !(Term name uni fun ann) ![Term name uni fun ann] + | Case !ann !(Term name uni fun ann) !(SixList (Term name uni fun ann)) deriving stock (Functor, Generic) +data SixList a + = SixList0 + | SixList1 !a + | SixList2 !a !a + | SixList3 !a !a !a + | SixList4 !a !a !a !a + | SixList5 !a !a !a !a !a + | SixList6 !a !a !a !a !a !a !(SixList a) + deriving stock (Show, Eq, Functor, Foldable, Traversable, Generic) + deriving anyclass (NFData, Hashable) + +instance IsList (SixList a) where + type Item (SixList a) = a + + fromList [] = SixList0 + fromList [x0] = SixList1 x0 + fromList [x0, x1] = SixList2 x0 x1 + fromList [x0, x1, x2] = SixList3 x0 x1 x2 + fromList [x0, x1, x2, x3] = SixList4 x0 x1 x2 x3 + fromList [x0, x1, x2, x3, x4] = SixList5 x0 x1 x2 x3 x4 + fromList (x0:x1:x2:x3:x4:x5:xs) = SixList6 x0 x1 x2 x3 x4 x5 (fromList xs) + + toList !xs0 = goStep xs0 where + goStep :: SixList a -> [a] + goStep SixList0 = [] + goStep (SixList1 x0) = [x0] + goStep (SixList2 x0 x1) = [x0, x1] + goStep (SixList3 x0 x1 x2) = [x0, x1, x2] + goStep (SixList4 x0 x1 x2 x3) = [x0, x1, x2, x3] + goStep (SixList5 x0 x1 x2 x3 x4) = [x0, x1, x2, x3, x4] + goStep (SixList6 x0 x1 x2 x3 x4 x5 xs) = x0 : x1 : x2 : x3 : x4 : x5 : goRec xs + {-# INLINE goStep #-} + + goRec :: SixList a -> [a] + goRec !xs = goStep xs + {-# NOINLINE goRec #-} + {-# INLINE toList #-} + +lookupSixList :: Word64 -> SixList a -> Maybe a +lookupSixList !i0 = goStep i0 . inline Exts.toList where + goStep :: Word64 -> [a] -> Maybe a + goStep 0 = \case + x:_ -> Just x + _ -> Nothing + goStep 1 = \case + _:x:_ -> Just x + _ -> Nothing + goStep 2 = \case + _:_:x:_ -> Just x + _ -> Nothing + goStep 3 = \case + _:_:_:x:_ -> Just x + _ -> Nothing + goStep 4 = \case + _:_:_:_:x:_ -> Just x + _ -> Nothing + goStep 5 = \case + _:_:_:_:_:x:_ -> Just x + _ -> Nothing + goStep i = \case + _:_:_:_:_:_:xs -> goRec (i - 6) xs + _ -> Nothing + {-# INLINE goStep #-} + + goRec :: Word64 -> [a] -> Maybe a + goRec !i = goStep i + {-# NOINLINE goRec #-} +{-# INLINE lookupSixList #-} + deriving stock instance (Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) => Show (Term name uni fun ann) @@ -123,7 +198,7 @@ instance TermLike (Term name uni fun) TPLC.TyName name uni fun where iWrap = \_ _ _ -> id error = \ann _ -> Error ann constr = \ann _ i es -> Constr ann i es - kase = \ann _ arg cs -> Case ann arg cs + kase = \ann _ arg cs -> Case ann arg $ fromList cs instance TPLC.HasConstant (Term name uni fun ()) where asConstant (Constant _ val) = pure val diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs index d310786a018..17b5cea59ef 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs @@ -85,7 +85,6 @@ import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts (CekMachineCosts CekMachineCostsBase (..)) import UntypedPlutusCore.Evaluation.Machine.Cek.StepCounter -import Control.Lens ((^?)) import Control.Lens.Review import Control.Monad (unless, when) import Control.Monad.Catch @@ -97,7 +96,6 @@ import Data.DList qualified as DList import Data.Functor.Identity import Data.Hashable (Hashable) import Data.Kind qualified as GHC -import Data.List.Extras (wix) import Data.Proxy import Data.Semigroup (stimes) import Data.Text (Text) @@ -574,7 +572,7 @@ data Context uni fun ann -- See Note [Accumulators for terms] | FrameConstr !(CekValEnv uni fun ann) {-# UNPACK #-} !Word64 ![NTerm uni fun ann] !(ArgStack uni fun ann) !(Context uni fun ann) -- ^ @(constr i V0 ... Vj-1 _ Nj ... Nn)@ - | FrameCases !(CekValEnv uni fun ann) ![NTerm uni fun ann] !(Context uni fun ann) + | FrameCases !(CekValEnv uni fun ann) !(SixList (NTerm uni fun ann)) !(Context uni fun ann) -- ^ @(case _ C0 .. Cn)@ | NoFrame @@ -768,7 +766,7 @@ enterComputeCek = computeCek _ -> returnCek ctx $ VConstr i done' -- s , case _ (C0 ... CN, ρ) ◅ constr i V1 .. Vm ↦ s , [_ V1 ... Vm] ; ρ ▻ Ci returnCek (FrameCases env cs ctx) e = case e of - (VConstr i args) -> case cs ^? wix i of + (VConstr i args) -> case lookupSixList i cs of Just t -> computeCek (transferArgStack args ctx) env t Nothing -> throwingDischarged _MachineError (MissingCaseBranch i) e _ -> throwingDischarged _MachineError NonConstrScrutinized e diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs index 5cf72765816..732eccb82ad 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs @@ -57,7 +57,6 @@ import UntypedPlutusCore.Evaluation.Machine.Cek.StepCounter import Control.Lens hiding (Context) import Control.Monad -import Data.List.Extras (wix) import Data.Proxy import Data.RandomAccessList.Class qualified as Env import Data.Semigroup (stimes) @@ -99,7 +98,7 @@ data Context uni fun ann | FrameAwaitFunValue ann !(CekValue uni fun ann) !(Context uni fun ann) | FrameForce ann !(Context uni fun ann) -- ^ @(force _)@ | FrameConstr ann !(CekValEnv uni fun ann) {-# UNPACK #-} !Word64 ![NTerm uni fun ann] !(ArgStack uni fun ann) !(Context uni fun ann) - | FrameCases ann !(CekValEnv uni fun ann) ![NTerm uni fun ann] !(Context uni fun ann) + | FrameCases ann !(CekValEnv uni fun ann) !(SixList (NTerm uni fun ann)) !(Context uni fun ann) | NoFrame deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) @@ -195,7 +194,7 @@ returnCek (FrameConstr ann env i todo done ctx) e = do _ -> returnCek ctx $ VConstr i done' -- s , case _ (C0 ... CN, ρ) ◅ constr i V1 .. Vm ↦ s , [_ V1 ... Vm] ; ρ ▻ Ci returnCek (FrameCases ann env cs ctx) e = case e of - (VConstr i args) -> case cs ^? wix i of + (VConstr i args) -> case lookupSixList i cs of Just t -> let ctx' = transferArgStack ann args ctx in computeCek ctx' env t diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs index 55bfab63110..02a102938f3 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs @@ -28,6 +28,7 @@ import UntypedPlutusCore.Core.Type qualified as UPLC import UntypedPlutusCore.Rename (Rename (rename)) import Data.Text (Text) +import GHC.Exts (fromList) import PlutusCore.Error (AsParserErrorBundle) import PlutusCore.MkPlc (mkIterApp) import PlutusCore.Parser hiding (parseProgram, parseTerm, program) @@ -81,7 +82,7 @@ constrTerm = withSpan $ \sp -> caseTerm :: Parser PTerm caseTerm = withSpan $ \sp -> inParens $ do - res <- UPLC.Case sp <$> (symbol "case" *> term) <*> many term + res <- UPLC.Case sp <$> (symbol "case" *> term) <*> (fromList <$> many term) whenVersion (\v -> v < plcVersion110) $ fail "'case' is not allowed before version 1.1.0" pure res diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseReduce.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseReduce.hs index c7f70cc54cc..7055a429caa 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseReduce.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseReduce.hs @@ -9,11 +9,12 @@ import UntypedPlutusCore.Core import Control.Lens (transformOf, (^?)) import Data.List.Extras +import GHC.Exts (toList) caseReduce :: Term name uni fun a -> Term name uni fun a caseReduce = transformOf termSubterms processTerm processTerm :: Term name uni fun a -> Term name uni fun a processTerm = \case - Case ann (Constr _ i args) cs | Just c <- cs ^? wix i -> mkIterApp c ((ann,) <$> args) - t -> t + Case ann (Constr _ i args) cs | Just c <- toList cs ^? wix i -> mkIterApp c ((ann,) <$> args) + t -> t diff --git a/plutus-metatheory/src/Untyped.hs b/plutus-metatheory/src/Untyped.hs index cf617f46041..a865c4e40f0 100644 --- a/plutus-metatheory/src/Untyped.hs +++ b/plutus-metatheory/src/Untyped.hs @@ -10,6 +10,7 @@ import UntypedPlutusCore import Data.ByteString as BS hiding (map) import Data.Text as T hiding (map) import Data.Word (Word64) +import GHC.Exts (IsList (..)) import Universe -- Untyped (Raw) syntax @@ -42,7 +43,7 @@ conv (Error _) = UError conv (Delay _ t) = UDelay (conv t) conv (Force _ t) = UForce (conv t) conv (Constr _ i es) = UConstr (toInteger i) (fmap conv es) -conv (Case _ arg cs) = UCase (conv arg) (fmap conv cs) +conv (Case _ arg cs) = UCase (conv arg) (toList (fmap conv cs)) tmnames = ['a' .. 'z'] @@ -63,5 +64,4 @@ uconv i (UBuiltin b) = Builtin () b uconv i (UDelay t) = Delay () (uconv i t) uconv i (UForce t) = Force () (uconv i t) uconv i (UConstr j xs) = Constr () (fromInteger j) (fmap (uconv i) xs) -uconv i (UCase t xs) = Case () (uconv i t) (fmap (uconv i) xs) - +uconv i (UCase t xs) = Case () (uconv i t) (fromList (fmap (uconv i) xs)) From 621af7092808aa749f676b0ec8b9eef81988e527 Mon Sep 17 00:00:00 2001 From: effectfully Date: Mon, 4 Mar 2024 23:33:42 +0100 Subject: [PATCH 2/2] 6 is 14 --- .../src/UntypedPlutusCore/Core/Type.hs | 84 +++++++++++++++---- 1 file changed, 68 insertions(+), 16 deletions(-) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs index f1a4f071aa7..149a8c42846 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs @@ -96,25 +96,41 @@ data Term name uni fun ann data SixList a = SixList0 - | SixList1 !a - | SixList2 !a !a - | SixList3 !a !a !a - | SixList4 !a !a !a !a - | SixList5 !a !a !a !a !a - | SixList6 !a !a !a !a !a !a !(SixList a) + | SixList1 !a + | SixList2 !a !a + | SixList3 !a !a !a + | SixList4 !a !a !a !a + | SixList5 !a !a !a !a !a + | SixList6 !a !a !a !a !a !a + | SixList7 !a !a !a !a !a !a !a + | SixList8 !a !a !a !a !a !a !a !a + | SixList9 !a !a !a !a !a !a !a !a !a + | SixList10 !a !a !a !a !a !a !a !a !a !a + | SixList11 !a !a !a !a !a !a !a !a !a !a !a + | SixList12 !a !a !a !a !a !a !a !a !a !a !a !a + | SixList13 !a !a !a !a !a !a !a !a !a !a !a !a !a + | SixList14 !a !a !a !a !a !a !a !a !a !a !a !a !a !a (SixList a) deriving stock (Show, Eq, Functor, Foldable, Traversable, Generic) deriving anyclass (NFData, Hashable) instance IsList (SixList a) where type Item (SixList a) = a - fromList [] = SixList0 - fromList [x0] = SixList1 x0 - fromList [x0, x1] = SixList2 x0 x1 - fromList [x0, x1, x2] = SixList3 x0 x1 x2 - fromList [x0, x1, x2, x3] = SixList4 x0 x1 x2 x3 - fromList [x0, x1, x2, x3, x4] = SixList5 x0 x1 x2 x3 x4 - fromList (x0:x1:x2:x3:x4:x5:xs) = SixList6 x0 x1 x2 x3 x4 x5 (fromList xs) + fromList [] = SixList0 + fromList [x0] = SixList1 x0 + fromList [x0, x1] = SixList2 x0 x1 + fromList [x0, x1, x2] = SixList3 x0 x1 x2 + fromList [x0, x1, x2, x3] = SixList4 x0 x1 x2 x3 + fromList [x0, x1, x2, x3, x4] = SixList5 x0 x1 x2 x3 x4 + fromList [x0, x1, x2, x3, x4, x5] = SixList6 x0 x1 x2 x3 x4 x5 + fromList [x0, x1, x2, x3, x4, x5, x6] = SixList7 x0 x1 x2 x3 x4 x5 x6 + fromList [x0, x1, x2, x3, x4, x5, x6, x7] = SixList8 x0 x1 x2 x3 x4 x5 x6 x7 + fromList [x0, x1, x2, x3, x4, x5, x6, x7, x8] = SixList9 x0 x1 x2 x3 x4 x5 x6 x7 x8 + fromList [x0, x1, x2, x3, x4, x5, x6, x7, x8, x9] = SixList10 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 + fromList [x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10] = SixList11 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 + fromList [x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11] = SixList12 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 + fromList [x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12] = SixList13 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 + fromList (x0:x1:x2:x3:x4:x5:x6:x7:x8:x9:x10:x11:x12:x13:xs) = SixList14 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 (fromList xs) toList !xs0 = goStep xs0 where goStep :: SixList a -> [a] @@ -124,7 +140,15 @@ instance IsList (SixList a) where goStep (SixList3 x0 x1 x2) = [x0, x1, x2] goStep (SixList4 x0 x1 x2 x3) = [x0, x1, x2, x3] goStep (SixList5 x0 x1 x2 x3 x4) = [x0, x1, x2, x3, x4] - goStep (SixList6 x0 x1 x2 x3 x4 x5 xs) = x0 : x1 : x2 : x3 : x4 : x5 : goRec xs + goStep (SixList6 x0 x1 x2 x3 x4 x5) = [x0, x1, x2, x3, x4, x5] + goStep (SixList7 x0 x1 x2 x3 x4 x5 x6) = [x0, x1, x2, x3, x4, x5, x6] + goStep (SixList8 x0 x1 x2 x3 x4 x5 x6 x7) = [x0, x1, x2, x3, x4, x5, x6, x7] + goStep (SixList9 x0 x1 x2 x3 x4 x5 x6 x7 x8) = [x0, x1, x2, x3, x4, x5, x6, x7, x8] + goStep (SixList10 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9) = [x0, x1, x2, x3, x4, x5, x6, x7, x8, x9] + goStep (SixList11 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) = [x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10] + goStep (SixList12 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) = [x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11] + goStep (SixList13 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12) = [x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12] + goStep (SixList14 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 xs) = x0 : x1 : x2 : x3 : x4 : x5 : x6 : x7 : x8 : x9 : x10 : x11 : x12 : x13 : goRec xs {-# INLINE goStep #-} goRec :: SixList a -> [a] @@ -132,6 +156,10 @@ instance IsList (SixList a) where {-# NOINLINE goRec #-} {-# INLINE toList #-} +-- >>> import GHC.IsList (fromList) +-- >>> import Data.Maybe +-- >>> mapMaybe (\i -> lookupSixList i $ fromList [0..20 :: Int]) [0..20] +-- [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20] lookupSixList :: Word64 -> SixList a -> Maybe a lookupSixList !i0 = goStep i0 . inline Exts.toList where goStep :: Word64 -> [a] -> Maybe a @@ -153,9 +181,33 @@ lookupSixList !i0 = goStep i0 . inline Exts.toList where goStep 5 = \case _:_:_:_:_:x:_ -> Just x _ -> Nothing + goStep 6 = \case + _:_:_:_:_:_:x:_ -> Just x + _ -> Nothing + goStep 7 = \case + _:_:_:_:_:_:_:x:_ -> Just x + _ -> Nothing + goStep 8 = \case + _:_:_:_:_:_:_:_:x:_ -> Just x + _ -> Nothing + goStep 9 = \case + _:_:_:_:_:_:_:_:_:x:_ -> Just x + _ -> Nothing + goStep 10 = \case + _:_:_:_:_:_:_:_:_:_:x:_ -> Just x + _ -> Nothing + goStep 11 = \case + _:_:_:_:_:_:_:_:_:_:_:x:_ -> Just x + _ -> Nothing + goStep 12 = \case + _:_:_:_:_:_:_:_:_:_:_:_:x:_ -> Just x + _ -> Nothing + goStep 13 = \case + _:_:_:_:_:_:_:_:_:_:_:_:_:x:_ -> Just x + _ -> Nothing goStep i = \case - _:_:_:_:_:_:xs -> goRec (i - 6) xs - _ -> Nothing + _:_:_:_:_:_:_:_:_:_:_:_:_:_:xs -> goRec (i - 14) xs + _ -> Nothing {-# INLINE goStep #-} goRec :: Word64 -> [a] -> Maybe a