From adb635f08deefaddb26b9145592a82d81b5cb547 Mon Sep 17 00:00:00 2001 From: Valentin Robert Date: Thu, 21 Mar 2024 11:31:11 -0700 Subject: [PATCH] clean up trailing whitespace --- _scratch/ADThrowaway.hs | 10 +- _scratch/Fr.hs | 7 +- _scratch/Lib/Parser/Fast.hs | 10 +- _scratch/Lib/Parser/Lexer.hs | 126 ++++---- _scratch/Lib/Parser/Old/Common.hs | 28 +- _scratch/Lib/Parser/Old/Core.hs | 16 +- _scratch/Lib/Parser/Old/Mixfix.hs | 16 +- _scratch/Lines.hs | 5 +- _scratch/OldMatrix.hs | 109 ++++--- _scratch/OldNewVector.hs | 55 ++-- _scratch/OldParserContext.hs | 50 +-- _scratch/OldPretty2/Class.hs | 4 +- _scratch/OldPretty2/Color.hs | 6 +- _scratch/OldPretty2/Console.hs | 14 +- _scratch/OldPretty2/ConsoleANSI.hs | 2 +- _scratch/OldPretty2/ConsoleHTML.hs | 4 +- _scratch/OldPretty2/Core.hs | 32 +- _scratch/OldPretty2/Deriving.hs | 24 +- _scratch/OldPretty2/Examples.hs | 2 +- _scratch/OldPretty2/NF.hs | 4 +- _scratch/OldSep.hs | 20 +- _scratch/OldVector.hs | 28 +- _scratch/OlderSep.hs | 22 +- .../Substitution_attempted_local_global.hs | 117 ++++--- _scratch/Tr.hs | 7 +- _scratch/VectorMultiDim.hs | 12 +- _scratch/WizPL.hs | 13 +- src/Examples/Lang/Arith.hs | 7 +- src/Examples/Lang/ArithBlocks.hs | 14 +- src/Examples/Lang/SExp.hs | 2 +- src/UVMHS/Core/Chunky.hs | 22 +- src/UVMHS/Core/Classes/Comonad.hs | 3 +- src/UVMHS/Core/Classes/Functors.hs | 36 +-- src/UVMHS/Core/Classes/Lattice.hs | 2 +- src/UVMHS/Core/Classes/Morphism.hs | 26 +- src/UVMHS/Core/Classes/Order.hs | 8 +- src/UVMHS/Core/Data/Arithmetic.hs | 288 +++++++++--------- src/UVMHS/Core/Data/Choice.hs | 10 +- src/UVMHS/Core/Data/Dict.hs | 113 ++++--- src/UVMHS/Core/Data/Function.hs | 8 +- src/UVMHS/Core/Data/Iter.hs | 46 +-- src/UVMHS/Core/Data/Lattice.hs | 20 +- src/UVMHS/Core/Data/Lens.hs | 5 +- src/UVMHS/Core/Data/List.hs | 15 +- src/UVMHS/Core/Data/Option.hs | 10 +- src/UVMHS/Core/Data/Pair.hs | 27 +- src/UVMHS/Core/Data/Sequence.hs | 16 +- src/UVMHS/Core/Data/Set.hs | 6 +- src/UVMHS/Core/Data/Stream.hs | 96 +++--- src/UVMHS/Core/Data/String.hs | 12 +- src/UVMHS/Core/Effects.hs | 52 ++-- src/UVMHS/Core/IO.hs | 9 +- src/UVMHS/Core/Init.hs | 12 +- src/UVMHS/Core/LensDeriving.hs | 23 +- src/UVMHS/Core/Monads.hs | 138 ++++----- src/UVMHS/Core/Pointed.hs | 57 ++-- src/UVMHS/Core/Static.hs | 24 +- src/UVMHS/Core/TH.hs | 16 +- src/UVMHS/Core/Transformers.hs | 2 +- src/UVMHS/Core/VectorSparse.hs | 12 +- src/UVMHS/Lang/ULC.hs | 10 +- src/UVMHS/Lib/Dataframe.hs | 51 ++-- src/UVMHS/Lib/GTree.hs | 32 +- src/UVMHS/Lib/Graph.hs | 8 +- src/UVMHS/Lib/MMSP.hs | 96 +++--- src/UVMHS/Lib/Options.hs | 4 +- src/UVMHS/Lib/Parser/CParser.hs | 16 +- src/UVMHS/Lib/Parser/Core.hs | 10 +- src/UVMHS/Lib/Parser/Examples.hs | 26 +- src/UVMHS/Lib/Parser/Mixfix.hs | 28 +- src/UVMHS/Lib/Parser/ParserContext.hs | 8 +- src/UVMHS/Lib/Parser/ParserError.hs | 22 +- src/UVMHS/Lib/Parser/ParserInput.hs | 6 +- src/UVMHS/Lib/Parser/Regex.hs | 140 ++++----- src/UVMHS/Lib/Pipeline.hs | 2 +- src/UVMHS/Lib/Pretty.hs | 2 +- src/UVMHS/Lib/Pretty/Annotation.hs | 4 +- src/UVMHS/Lib/Pretty/Color.hs | 8 +- src/UVMHS/Lib/Pretty/Common.hs | 24 +- src/UVMHS/Lib/Pretty/Deriving.hs | 61 ++-- src/UVMHS/Lib/Pretty/Doc.hs | 76 ++--- src/UVMHS/Lib/Pretty/DocA.hs | 12 +- src/UVMHS/Lib/Pretty/RenderANSI.hs | 34 +-- src/UVMHS/Lib/Pretty/RenderUndertags.hs | 6 +- src/UVMHS/Lib/Pretty/Shape.hs | 46 +-- src/UVMHS/Lib/Rand.hs | 32 +- src/UVMHS/Lib/Sep.hs | 9 +- src/UVMHS/Lib/Substitution.hs | 72 ++--- src/UVMHS/Lib/Testing.hs | 26 +- src/UVMHS/Lib/TreeAnnote.hs | 12 +- src/UVMHS/Lib/TreeNested.hs | 18 +- src/UVMHS/Lib/Variables.hs | 2 +- src/UVMHS/Lib/Window.hs | 81 +++-- src/UVMHS/Lib/ZerInf.hs | 4 +- src/UVMHS/Tests/Core.hs | 11 +- src/UVMHS/Tests/Substitution.hs | 42 +-- 96 files changed, 1447 insertions(+), 1474 deletions(-) diff --git a/_scratch/ADThrowaway.hs b/_scratch/ADThrowaway.hs index 9a1d8eb6..9b2bae23 100644 --- a/_scratch/ADThrowaway.hs +++ b/_scratch/ADThrowaway.hs @@ -12,7 +12,7 @@ -- Dual Number Forward Generic -- --------------------------------- -data DNF a b = DNF +data DNF a b = DNF { dnfVal ∷ a , dnfDer ∷ b } deriving (Eq,Ord,Show) @@ -149,7 +149,7 @@ deriving instance (𝒩 m,𝒩 n) ⇒ Times (DNFJ𝔻 m n) -- Dual Number Backward Generic -- ---------------------------------- -data DNB a b = DNB +data DNB a b = DNB { dnbVal ∷ a , dnbDer ∷ a → b } @@ -163,7 +163,7 @@ sensDNB ∷ a → (a → b) → DNB a b sensDNB = DNB plusDNB ∷ (Plus a,Plus b) ⇒ DNB a b → DNB a b → DNB a b -plusDNB (DNB v₁ d₁) (DNB v₂ d₂) = DNB (v₁ + v₂) $ \ δ → +plusDNB (DNB v₁ d₁) (DNB v₂ d₂) = DNB (v₁ + v₂) $ \ δ → d₁ δ + d₂ δ timesDNB ∷ (Times a,Plus b) ⇒ DNB a b → DNB a b → DNB a b @@ -305,7 +305,7 @@ type DNBMC = AllCC 𝒩 data DNBM (ms ∷ [𝐍]) (nss ∷ [[𝐍]]) a = DNBM { dnbmVal ∷ 𝕄S ms a - , dnbmDer ∷ 𝕄S ms a → 𝐿S nss DNBMC (𝕄S' a) → 𝐿S nss DNBMC (𝕄S' a) + , dnbmDer ∷ 𝕄S ms a → 𝐿S nss DNBMC (𝕄S' a) → 𝐿S nss DNBMC (𝕄S' a) } makeLenses ''DNBM makePrettySum ''DNBM @@ -329,5 +329,3 @@ timesDNBM ∷ (AllC 𝒩 ms,Times a) ⇒ DNBM ms nss a → DNBM ms nss a → DNB timesDNBM (DNBM v₁ 𝒹₁) (DNBM v₂ 𝒹₂) = DNBM (v₁ × v₂) $ \ d → 𝒹₁ (d × v₂) ∘ 𝒹₂ (d × v₁) -- }}} - - diff --git a/_scratch/Fr.hs b/_scratch/Fr.hs index ce8429b0..3feb0d19 100644 --- a/_scratch/Fr.hs +++ b/_scratch/Fr.hs @@ -19,7 +19,7 @@ data FrI hᴵ hᴼ o a where Fr1 ∷ ∀ h o a. Tr h o a → FrI h h o a Fr2 ∷ ∀ hᴵ hᴼ o a. Br hᴵ o a → Fr ('S hᴵ) hᴼ o a → Br hᴵ o a → FrI hᴵ hᴼ o a -data ExTallFr h o a where +data ExTallFr h o a where EqTlFr ∷ ∀ h o a. Fr 'Z h o a → ExTallFr h o a SuccFr ∷ ∀ h o a. Fr 'Z ('S h) o a → ExTallFr h o a @@ -297,7 +297,7 @@ snocFrK f x (InFr2 bˡ () bʳ c) = consFrBrK x bʳ $ InFr2R bˡ f () c insertPosFr ∷ (Monoid o,Summary o a) ⇒ a → PositionFr h o a → ExTallFr h o a insertPosFr x (PositionFr0 c) = consFrK x fr0 c -insertPosFr x (PositionFr2 d f c) = case d of +insertPosFr x (PositionFr2 d f c) = case d of Left → consFrK x f c Right → snocFrK f x c insertPosFr x (PositionFrBr d b c) = case d of @@ -396,7 +396,7 @@ data FrK𝑆 o a where data BrInFr𝑆 o a where InFr2L𝑆 ∷ ∀ hᴵ hᴼ o a. () → Fr ('S hᴵ) hᴼ o a → Br hᴵ o a → FrK𝑆 o a → BrInFr𝑆 o a InFr2R𝑆 ∷ ∀ o a . () → FrK𝑆 o a → BrInFr𝑆 o a - + data TrInFr𝑆 o a where InFr1𝑆 ∷ ∀ o a. () → FrK𝑆 o a → TrInFr𝑆 o a InBr1𝑆 ∷ ∀ o a. () → BrInFr𝑆 o a → TrInFr𝑆 o a @@ -438,4 +438,3 @@ streamFr f = 𝑆 (locFstFr𝑆 f TopFr𝑆) $ \case Some (x :* c :* cc) → Some (x :* nextFr𝑆 c cc) instance ToStream a (Fr hᴵ hᴼ o a) where stream = streamFr - diff --git a/_scratch/Lib/Parser/Fast.hs b/_scratch/Lib/Parser/Fast.hs index 23574d7c..dba30a58 100644 --- a/_scratch/Lib/Parser/Fast.hs +++ b/_scratch/Lib/Parser/Fast.hs @@ -33,16 +33,16 @@ data CParser t a = CParser , cParserFallback ∷ Formats ⇰ (𝐼 t → Parser t a) } -instance Return (CParser t) where +instance Return (CParser t) where -- {-# INLINE return #-} return ∷ ∀ a. a → CParser t a return x = CParser dø None $ null ↦ const (return x) instance (Ord t) ⇒ Bind (CParser t) where -- {-# INLINE (≫=) #-} (≫=) ∷ ∀ a b. CParser t a → (a → CParser t b) → CParser t b - CParser n nf f ≫= k = - CParser (map (mapCResultsParsers $ extend k) n) - (map (mapCResultsParsers $ extend k) nf) + CParser n nf f ≫= k = + CParser (map (mapCResultsParsers $ extend k) n) + (map (mapCResultsParsers $ extend k) nf) (map (map $ extend $ cparser ∘ k) f) instance (Ord t) ⇒ Functor (CParser t) where map = mmap instance (Ord t) ⇒ Monad (CParser t) @@ -104,5 +104,5 @@ cunit fm f = CParser dø None $ fm ↦ return ∘ f -- {-# INLINE cpWord #-} cpWord ∷ ∀ s t. (Ord t,Eq t,s ⇄ 𝐼 t) ⇒ Formats → s → CParser t s -cpWord fm ts = foldrOnFrom (isoto ts) (cunit fm isofr) $ \ c cp → +cpWord fm ts = foldrOnFrom (isoto ts) (cunit fm isofr) $ \ c cp → CParser (c ↦ CResults False {- pø -} cp) (Some (CResults True {- null -} {- (single $ ppshow ts) -} null)) dø diff --git a/_scratch/Lib/Parser/Lexer.hs b/_scratch/Lib/Parser/Lexer.hs index decff053..f4fef21c 100644 --- a/_scratch/Lib/Parser/Lexer.hs +++ b/_scratch/Lib/Parser/Lexer.hs @@ -52,7 +52,7 @@ instance (Ord c,Ord t,Classified c t) ⇒ Append (Lexer c t) where (None,None) → None (None,Some nfm) → Some nfm (Some nfm,None) → Some nfm - (Some (n₁ :* fm₁),Some (n₂ :* fm₂)) + (Some (n₁ :* fm₁),Some (n₂ :* fm₂)) | n₁ ≥ n₂ → Some (n₁ :* fm₁) | otherwise → Some (n₂ :* fm₂) h = h₁ ⩓ h₂ @@ -139,7 +139,7 @@ instance Functor (Lexer t) where map ∷ ∀ a b. (a → b) → Lexer t a → Lexer t b map f (Lexer n c) = Lexer (mapp f n) $ map f c -instance Return (Lexer t) where +instance Return (Lexer t) where return ∷ ∀ a. a → Lexer t a return x = Lexer dø $ LResult zero $ null ↦ return x @@ -189,7 +189,7 @@ lunit n fmt x = Lexer dø $ LResult n $ fmt ↦ return x -- lOneThen ∷ (Ord t) ⇒ t → Lexer t a → Lexer t a -- lOneThen t l = Lexer (t ↦ l) Null Null --- +-- -- lSatisfyThen ∷ (t → 𝔹) → (() → Lexer t a ) → Lexer t a -- lSatisfyThen f l = Lexer dø (AddNull $ \ t → if f t then l () else null) Null @@ -208,7 +208,7 @@ lsat n fm f = toLexer n $ do -- in l' -- lWhitespace ∷ ℕ64 → Lexer ℂ 𝕊 --- lWhitespace n = +-- lWhitespace n = -- let l = (lSatisfyThen isSpace $ \ () → l) ⧺ lUnit n null True stringS -- in lSatisfyThen isSpace $ const l @@ -219,8 +219,8 @@ lWhitespace n = string ^$ oneOrMore $ lsat n null isSpace -- lName n = toLexer n $ do -- c ← lsat n isLetter -- cs ← many $ lsat $ \ c → joins --- [ isLetter c --- , isNumber c +-- [ isLetter c +-- , isNumber c -- , c ∈ pow "_-'′" -- ] -- return $ string $ c :& cs @@ -233,7 +233,7 @@ lWhitespace n = string ^$ oneOrMore $ lsat n null isSpace -- return $ s₁ ⧺ s₂ ⧺ s₃ -- lComment ∷ ℕ64 → Lexer ℂ 𝕊 --- lComment n = +-- lComment n = -- let nl = lWord n null iter stringS "\n" -- in undefined @@ -279,43 +279,43 @@ lWhitespace n = string ^$ oneOrMore $ lsat n null isSpace -- null = Lazy null -- instance (Append a) ⇒ Append (Lazy a) where -- ~(Lazy x) ⧺ ~(Lazy y) = Lazy (x ⧺ y) --- +-- -- instance Functor Lazy where -- map f ~(Lazy x) = Lazy (f x) --- +-- -- class Sequence t where (⨟) ∷ t a → t b → t (a ∧ b) --- +-- -- ----------------- -- -- LexerResult -- -- ----------------- --- +-- -- data LexerResult t a = LexerResult -- { lexerResultLevel ∷ ℕ64 -- , lexerResultFormat ∷ Formats -- , lexerResultSkip ∷ 𝔹 -- , lexerResultBuilder ∷ 𝐼S t → a -- } --- +-- -- instance Append (LexerResult t a) where -- lr₁ ⧺ lr₂ -- | lexerResultLevel lr₁ ≥ lexerResultLevel lr₂ = lr₁ -- | otherwise = lr₂ --- +-- -- instance Functor (LexerResult t) where -- map ∷ ∀ a b. (a → b) → LexerResult t a → LexerResult t b -- map f (LexerResult n fm sk g) = LexerResult n fm sk $ f ∘ g --- +-- -- instance Sequence (LexerResult t) where -- (⨟) ∷ ∀ a b. LexerResult t a → LexerResult t b → LexerResult t (a ∧ b) -- LexerResult n₁ f₁ sk₁ g₁ ⨟ LexerResult n₂ f₂ sk₂ g₂ = --- LexerResult (n₁ ⊓ n₂) (f₁ ⧺ f₂) (sk₁ ⩓ sk₂) $ \ ts → g₁ ts :* g₂ ts --- +-- LexerResult (n₁ ⊓ n₂) (f₁ ⧺ f₂) (sk₁ ⩓ sk₂) $ \ ts → g₁ ts :* g₂ ts +-- -- data Lexer t a = Lexer -- { lexerNext ∷ t ⇰ Lazy (Lexer t a) -- , lexerFallback ∷ AddNull (t → Lexer t a) -- , lexerResult ∷ AddNull (LexerResult t a) -- } --- +-- -- instance Null (Lexer t a) where -- null ∷ Lexer t a -- null = Lexer dø Null null @@ -334,11 +334,11 @@ lWhitespace n = string ^$ oneOrMore $ lsat n null isSpace -- fBoth = fO₁ ⧺ fO₂ -- in Lexer (unionsWith (⧺) [nBoth,n₁Extra n₁Only,n₂Extra n₂Only]) fBoth $ r₁ ⧺ r₂ -- instance (Ord t) ⇒ Monoid (Lexer t a) --- +-- -- instance Functor (Lexer t) where -- map ∷ ∀ a b. (a → b) → Lexer t a → Lexer t b -- map f (Lexer n fO r) = Lexer (mapp (map f) n) (mapp (map f) fO) (map (map f) r) --- +-- -- instance (Ord t) ⇒ Sequence (Lexer t) where -- (⨟) ∷ ∀ a b. Lexer t a → Lexer t b → Lexer t (a ∧ b) -- Lexer n₁ fO₁ rO₁ ⨟ l@(Lexer n₂ fO₂ rO₂) = @@ -351,12 +351,12 @@ lWhitespace n = string ^$ oneOrMore $ lsat n null isSpace -- (AddNull r₁,AddNull r₂) → AddNull $ r₁ ⨟ r₂ -- _ → Null -- in Lexer (n₁' ⧺ n₂') (fO₁' ⧺ fO₂') rO' --- --- +-- +-- -- ---------------- -- -- LexerState -- -- ---------------- --- +-- -- data LexerState t = LexerState -- { lexerStateContext ∷ ParserContext -- , lexerStateSuffix ∷ WindowL Doc Doc @@ -364,15 +364,15 @@ lWhitespace n = string ^$ oneOrMore $ lsat n null isSpace -- } -- makeLenses ''LexerState -- makePrettyRecord ''LexerState --- +-- -- lexerState₀ ∷ ParserInput t → LexerState t -- lexerState₀ = LexerState null null --- +-- -- type LexerM t = StateT (LexerState t) 𝑂 --- +-- -- runLexer ∷ LexerState t → LexerM t a → 𝑂 (LexerState t ∧ a) -- runLexer = runStateT --- +-- -- lAdvance ∷ LexerM t (ParserToken t) -- lAdvance = do -- pi ← getL lexerStateInputL @@ -384,12 +384,12 @@ lWhitespace n = string ^$ oneOrMore $ lsat n null isSpace -- lAdvance -- else do -- return $ ParserToken x sk tc ts --- +-- -- lRecord ∷ ParserToken t → LexerM t () -- lRecord t = do -- modifyL lexerStateContextL $ \ pc → pc ⧺ parserTokenContext t -- putL lexerStateSuffixL $ parserTokenSuffix t --- +-- -- interpLexer ∷ ∀ t a. (Ord t) ⇒ Lexer t a → LexerM t (𝔹 ∧ a) -- interpLexer l₀ = loop null l₀ -- where @@ -407,8 +407,8 @@ lWhitespace n = string ^$ oneOrMore $ lsat n null isSpace -- modifyL lexerStateContextL $ formatParserContext fm -- return $ sk :* f ts -- ] --- --- +-- +-- -- tokenize ∷ ∀ t a. (Ord t) ⇒ Lexer t a → 𝑆 (ParserToken t) → Doc ∨ 𝑆 (ParserToken a) -- tokenize l ts = mapInr (stream ∘ vecS ∘ fst) $ loop null $ lexerState₀ $ parserInput₀ ts -- where @@ -427,39 +427,39 @@ lWhitespace n = string ^$ oneOrMore $ lsat n null isSpace -- ts' :* ps' ← loop (pp ⧺ parserContextDisplayR pc) σ' -- let t' = ParserToken x sk pc ps' -- return $ (ts' ⧺ single t') :* (parserContextDisplayL pc ⧺ ps') --- +-- -- lUnit ∷ ℕ64 → Formats → 𝔹 → (𝐼S t → a) → Lexer t a -- lUnit n fm sk f = Lexer dø Null $ AddNull $ LexerResult n fm sk f --- +-- -- lOneThen ∷ (Ord t) ⇒ t → Lazy (Lexer t a) → Lexer t a -- lOneThen t l = Lexer (t ↦ l) Null Null --- +-- -- lSatisfyThen ∷ (t → 𝔹) → (() → Lexer t a ) → Lexer t a -- lSatisfyThen f l = Lexer dø (AddNull $ \ t → if f t then l () else null) Null --- +-- -- lWord ∷ (Ord t,Eq t) ⇒ ℕ64 → Formats → (s → 𝐼 t) → (𝐼S t → s) → s → Lexer t s -- lWord n fm to fr ts = foldrOnFrom (to ts) (lUnit n fm False fr) $ \ c cp → lOneThen c $ Lazy cp --- +-- -- -- lSatisfies ∷ ℕ64 → Formats → (t → 𝔹) → Lexer t (𝐼S t) -- -- lSatisfies n fm f = Lexer dø (AddNull $ \ x → if f x then lUnit n fm False else null) Null --- +-- -- -- lMany ∷ (Ord t) ⇒ ℕ64 → Formats → 𝔹 → Lexer t a → b → (a → b → b) → Lexer t b -- -- lMany n fm sk l i f = -- -- let ~l' = map (const i) (lUnit n fm sk) ⧺ (map (\ (x :* xs) → f x xs) (l ⨟ l')) -- -- in l' --- +-- -- lWhitespace ∷ ℕ64 → Lexer ℂ 𝕊 --- lWhitespace n = +-- lWhitespace n = -- let l = (lSatisfyThen isSpace $ \ () → l) ⧺ lUnit n null True stringS -- in lSatisfyThen isSpace $ const l --- +-- -- lName ∷ ℕ64 → Lexer ℂ 𝕊 -- lName n = -- let l = (lSatisfyThen (\ c → joins [isLetter c,isNumber c,c ∈ pow "_-'′"]) $ \ () → l) ⧺ lUnit n null False stringS -- in lLexer dø (AddNull $ \ c → if isLetter c then l else null) Null --- +-- -- lComment ∷ ℕ64 → Lexer ℂ 𝕊 --- lComment n = +-- lComment n = -- let nl = lWord n null iter stringS "\n" -- in undefined @@ -478,21 +478,21 @@ lWhitespace n = string ^$ oneOrMore $ lsat n null isSpace -- LOH -- Make it look like old "fast" parser where when done you get a LexerM -- not just an a ; get that working and benchmarked first. --- --- --- --- +-- +-- +-- +-- -- -- import UVMHS.Core --- -- +-- -- -- -- import UVMHS.Lib.Pretty --- -- +-- -- -- -- import UVMHS.Lib.Parser.ParserContext -- -- import UVMHS.Lib.Parser.ParserInput --- -- +-- -- -- -- ---------------- -- -- -- LexerState -- -- -- ---------------- --- -- +-- -- -- -- data LexerState t = LexerState -- -- { lexerStateContext ∷ ParserContext -- -- , lexerStateSuffix ∷ WindowL Doc Doc @@ -500,21 +500,21 @@ lWhitespace n = string ^$ oneOrMore $ lsat n null isSpace -- -- } -- -- makeLenses ''LexerState -- -- makePrettyRecord ''LexerState --- -- +-- -- -- -- lexerState₀ ∷ ParserInput t → LexerState t -- -- lexerState₀ = LexerState null --- -- +-- -- -- -- ----------- -- -- -- Lexer -- -- -- ----------- --- -- +-- -- -- -- newtype Lexer t a = Lexer { unLexer ∷ StateT (LexerState t) 𝑂 a } --- -- deriving +-- -- deriving -- -- ( Functor,Return,Bind,Monad -- -- , MonadFail -- -- , MonadState (LexerState t) -- -- ) --- -- +-- -- -- -- lAdvance ∷ Lexer t (AddBot Loc ∨ ParserToken t) -- -- lAdvance = do -- -- pi ← getL parserStateInputL @@ -526,16 +526,16 @@ lWhitespace n = string ^$ oneOrMore $ lsat n null isSpace -- -- pc ← getL parserStateContextL -- -- return $ Inr $ ParserToken x False (formatParserContext fmt tc) ts -- -- import UVMHS.Core --- -- +-- -- -- -- import UVMHS.Lib.Pretty --- -- +-- -- -- -- import UVMHS.Lib.Parser.ParserContext -- -- import UVMHS.Lib.Parser.ParserInput --- -- +-- -- -- -- ---------------- -- -- -- LexerState -- -- -- ---------------- --- -- +-- -- -- -- data LexerState t = LexerState -- -- { lexerStateContext ∷ ParserContext -- -- , lexerStateSuffix ∷ WindowL Doc Doc @@ -543,21 +543,21 @@ lWhitespace n = string ^$ oneOrMore $ lsat n null isSpace -- -- } -- -- makeLenses ''LexerState -- -- makePrettyRecord ''LexerState --- -- +-- -- -- -- lexerState₀ ∷ ParserInput t → LexerState t -- -- lexerState₀ = LexerState null --- -- +-- -- -- -- ----------- -- -- -- Lexer -- -- -- ----------- --- -- +-- -- -- -- newtype Lexer t a = Lexer { unLexer ∷ StateT (LexerState t) 𝑂 a } --- -- deriving +-- -- deriving -- -- ( Functor,Return,Bind,Monad -- -- , MonadFail -- -- , MonadState (LexerState t) -- -- ) --- -- +-- -- -- -- lAdvance ∷ Lexer t (AddBot Loc ∨ ParserToken t) -- -- lAdvance = do -- -- pi ← getL parserStateInputL diff --git a/_scratch/Lib/Parser/Old/Common.hs b/_scratch/Lib/Parser/Old/Common.hs index 8ad0edd9..56fae9bf 100644 --- a/_scratch/Lib/Parser/Old/Common.hs +++ b/_scratch/Lib/Parser/Old/Common.hs @@ -49,7 +49,7 @@ data LocRange = LocRange makeLenses ''LocRange makePrettyUnion ''LocRange -instance Join LocRange where +instance Join LocRange where LocRange b₁ e₁ ⊔ LocRange b₂ e₂ = LocRange (b₁ ⊓ b₂) (e₁ ⊔ e₂) -- # SourceToken @@ -93,7 +93,7 @@ sourceInput₀ ss = SourceInput ss loc₀ -- # SourceErrorTrace -data SourceErrorTrace = SourceErrorTrace +data SourceErrorTrace = SourceErrorTrace { sourceErrorTraceFinal ∷ 𝒫 𝕊 , sourceErrorTraceChain ∷ 𝕊 ⇰ SourceErrorTrace } deriving (Eq, Ord) @@ -108,7 +108,7 @@ instance JoinLattice SourceErrorTrace sourceErrorTraceFromStack ∷ [𝕊] → 𝕊 → SourceErrorTrace sourceErrorTraceFromStack [] fin = SourceErrorTrace (single fin) bot -sourceErrorTraceFromStack (msg:msgs) fin = +sourceErrorTraceFromStack (msg:msgs) fin = SourceErrorTrace bot $ dict [msg ↦ sourceErrorTraceFromStack msgs fin] displaySourceErrorTrace ∷ SourceErrorTrace → Doc @@ -145,10 +145,10 @@ makeLenses ''SourceError makePrettyRecord ''SourceError sourceErrorAppend ∷ SourceError t → SourceError t → SourceError t -sourceErrorAppend (SourceError pin₁ ectxs₁) (SourceError pin₂ ectxs₂) = +sourceErrorAppend (SourceError pin₁ ectxs₁) (SourceError pin₂ ectxs₂) = case sourceInputNextLoc pin₁ ⋚ sourceInputNextLoc pin₂ of LT → SourceError pin₂ ectxs₂ - EQ → + EQ → SourceError pin₁ $ unionWithDictOn ectxs₁ ectxs₂ $ \ pei₁ pei₂ → let SourceErrorInfo pre₁ trace₁ = pei₁ SourceErrorInfo _ trace₂ = pei₂ @@ -170,17 +170,17 @@ instance Monoid (SourceError𝒪 t) where displaySourceError𝒪 ∷ SourceError𝒪 t → Doc displaySourceError𝒪 NullSourceError = ppHeader "Nothing to Parse" -displaySourceError𝒪 (SourceError𝒪 (SourceError (SourceInput ts (Loc _ row col)) ectxs)) = +displaySourceError𝒪 (SourceError𝒪 (SourceError (SourceInput ts (Loc _ row col)) ectxs)) = ppVertical $ concat [ return $ ppHeader "Parse Failure" - , return $ ppHorizontal + , return $ ppHorizontal [ ppErr ">" , concat [ppText "row:",pretty row] , concat [ppText "col:",pretty col] ] , return $ ppHeader "One Of:" - , intersperse (ppHeader "OR") $ mapOn (list ectxs) $ - \ ((locRange,ctx),SourceErrorInfo pre etrace) → + , intersperse (ppHeader "OR") $ mapOn (list ectxs) $ + \ ((locRange,ctx),SourceErrorInfo pre etrace) → let (tokRange,nextTok,followStream) = case unconsStream ts of Nothing → (Bot,ppErr "EOF",null) Just (x,ts') → (AddBot $ sourceTokenRange x,sourceTokenError x,ts') @@ -211,7 +211,7 @@ makeLenses ''SourceContextPrefix instance Pretty (SourceContextPrefix t) where pretty (SourceContextPrefix prefix display displayError range) = - ppRecord "=" + ppRecord "=" [ ppText "display" ↦ prefix ⧺ ppUT '^' green display , ppText "displayError" ↦ prefix ⧺ ppUT '^' red displayError , ppText "range" ↦ pretty range @@ -222,7 +222,7 @@ instance Monoid (SourceContextPrefix t) where pc₁ ⧺ pc₂ = let SourceContextPrefix pre₁ display₁ displayError₁ range₁ = pc₁ SourceContextPrefix _ display₂ displayError₂ range₂ = pc₂ - in SourceContextPrefix pre₁ + in SourceContextPrefix pre₁ (display₁ ⧺ display₂) (displayError₁ ⧺ displayError₂) (range₁ ⊔ range₂) pushSourceLocalContext ∷ SourceContextPrefix t → SourceContextPrefix t @@ -235,7 +235,7 @@ errorSourceLocalContext pi (stack,message) (SourceContextPrefix prefix display _ [(range,display) ↦ SourceErrorInfo prefix (sourceErrorTraceFromStack (reverse stack) message)] sourceLocalContextFromToken ∷ [Format] → SourceToken t → SourceContextPrefix t -sourceLocalContextFromToken fmt (SourceToken _ range render renderError) = +sourceLocalContextFromToken fmt (SourceToken _ range render renderError) = SourceContextPrefix null (ppFormat fmt render) (ppFormat fmt renderError) (AddBot range) -- # SourceContext @@ -255,7 +255,7 @@ instance Pretty (SourceContext t) where Bot → id AddBot (LocRange begin end) → compose [ ppSetLineNumber (𝕟 0) - , ppLineNumbers + , ppLineNumbers , ppBlinders (locRow begin) (locRow end) ] in ff $ pre ⧺ (ppUT '^' green display) ⧺ concat (map sourceTokenRender ss) @@ -266,7 +266,7 @@ displaySourceContext (SourceContext (SourceContextPrefix pre display _ range) (S Bot → id AddBot (LocRange begin end) → compose [ ppSetLineNumber (𝕟 0) - , ppLineNumbers + , ppLineNumbers , ppBlinders (locRow begin) (locRow end) ] in ff $ pre ⧺ display ⧺ concat (map sourceTokenRender ss) diff --git a/_scratch/Lib/Parser/Old/Core.hs b/_scratch/Lib/Parser/Old/Core.hs index d15213a7..2f18ebd5 100644 --- a/_scratch/Lib/Parser/Old/Core.hs +++ b/_scratch/Lib/Parser/Old/Core.hs @@ -9,8 +9,8 @@ import FP.Parser.Effects -- Parser Monad -- ------------------ -newtype Parser t a = Parser { runParser ∷ ReaderT (ParserEnv t) (StateT (ParserState t) (NondetAppendT (Writer (ParserOut t)))) a - } deriving +newtype Parser t a = Parser { runParser ∷ ReaderT (ParserEnv t) (StateT (ParserState t) (NondetAppendT (Writer (ParserOut t)))) a + } deriving ( Functor,Monad , MonadReader (ParserEnv t) , MonadWriter (ParserOut t) @@ -96,7 +96,7 @@ pCatch cM xM = do pError ∷ 𝕊 → Parser t a → Parser t a pError msg = compose - [ fst ^∘ pNewContext parserStateErrorContextL + [ fst ^∘ pNewContext parserStateErrorContextL , local (update parserEnvErrorStackL ([],msg)) ] @@ -233,7 +233,7 @@ pSurrounded uM = pSurroundedBy uM uM --------------------- -- Running Parsers -- --------------------- - + runParser₀ ∷ (ToStream (SourceToken t) ts) ⇒ Parser t a → ts → ([(a,ParserState t)],ParserOut t) runParser₀ p ts = runParserWith parserEnv₀ (parserState₀ $ stream ts) p @@ -278,7 +278,7 @@ tokenize p ss = loop (parserState₀ $ stream ss) null Just ((x,cc),s') → do xs ← loop s' $ ParserOut sd pe' let locRange = case sourceContextPrefixRange cc of - Bot → + Bot → let loc = sourceInputNextLoc $ parserStateInput s in LocRange loc loc AddBot r → r @@ -341,7 +341,7 @@ testParsingMultipleFailure = parseIOMain parser input ] input ∷ Stream (SourceToken ℂ) input = tokens "xxxx" - + testParsingBlinders ∷ IO () testParsingBlinders = parseIOMain parser input where @@ -357,9 +357,9 @@ testParsingBlinders = parseIOMain parser input testParsingAmbiguity ∷ IO () testParsingAmbiguity = parseIOMain parser input where - parser = concat ^$ oneOrMore $ mconcat + parser = concat ^$ oneOrMore $ mconcat [ ppFG green ∘ ppText ∘ single ^$ pLit 'x' - , ppFG blue ∘ ppText ^$ pWord "xx" + , ppFG blue ∘ ppText ^$ pWord "xx" ] input = tokens "xxx" diff --git a/_scratch/Lib/Parser/Old/Mixfix.hs b/_scratch/Lib/Parser/Old/Mixfix.hs index c83a9044..f8f73668 100644 --- a/_scratch/Lib/Parser/Old/Mixfix.hs +++ b/_scratch/Lib/Parser/Old/Mixfix.hs @@ -28,7 +28,7 @@ data MixesF t f a = MixesF instance Monoid (MixesF t f a) where null = MixesF mnull mnull mnull mnull mnull - MixesF pre₁ post₁ inf₁ infl₁ infr₁ ⧺ MixesF pre₂ post₂ inf₂ infl₂ infr₂ = + MixesF pre₁ post₁ inf₁ infl₁ infr₁ ⧺ MixesF pre₂ post₂ inf₂ infl₂ infr₂ = MixesF (pre₁ <⧺> pre₂) (post₁ <⧺> post₂) (inf₁ <⧺> inf₂) (infl₁ <⧺> infl₂) (infr₁ <⧺> infr₂) data MixF t f a = @@ -57,11 +57,11 @@ mixF (TerminalF term) = null {mixfixFTerminals = term} -- PRE (PRE (x INFR (PRE (PRE y)))) -- PRE PRE x INFR PRE PRE y --- +-- -- ((((x POST) POST) INFL y) POST) POST -- x POST POST INFL y POST POST -mixfixParserF ∷ +mixfixParserF ∷ ∀ t f a. (Comonad f) ⇒ MixfixF t f a → (Parser t a → Parser t (f a)) → Parser t (f a) mixfixParserF (MixfixF terms levels₀) fld = loop levels₀ @@ -71,9 +71,9 @@ mixfixParserF (MixfixF terms levels₀) fld = loop levels₀ Nothing → fld $ terms Just ((i,mixes),levels') → let msg = "lvl " ⧺ alignRightFill '0' (𝕟 3) (ppString i) - in - fld $ buildLevelDirected msg mixes $ - fld $ buildLevelNondirected msg mixes $ + in + fld $ buildLevelDirected msg mixes $ + fld $ buildLevelNondirected msg mixes $ loop levels' buildLevelNondirected ∷ 𝕊 → MixesF t f a → Parser t (f a) → Parser t a buildLevelNondirected msg mixes nextLevel = do @@ -153,7 +153,7 @@ data Mixes t a = Mixes instance Monoid (Mixes t a) where null = Mixes mnull mnull mnull mnull mnull - Mixes pre₁ post₁ inf₁ infl₁ infr₁ ⧺ Mixes pre₂ post₂ inf₂ infl₂ infr₂ = + Mixes pre₁ post₁ inf₁ infl₁ infr₁ ⧺ Mixes pre₂ post₂ inf₂ infl₂ infr₂ = Mixes (pre₁ <⧺> pre₂) (post₁ <⧺> post₂) (inf₁ <⧺> inf₂) (infl₁ <⧺> infl₂) (infr₁ <⧺> infr₂) mixesPure ∷ Mixes t a → MixesF t ID a @@ -165,7 +165,7 @@ mixesPure (Mixes pre post inf infl infr) = (map kextract2 infl) (map kextract2 infr) -data Mixfix t a = Mixfix +data Mixfix t a = Mixfix { mixfixTerminals ∷ Parser t a , mixfixLevels ∷ ℕ ⇰ Mixes t a } diff --git a/_scratch/Lines.hs b/_scratch/Lines.hs index 67ba2daa..b0972601 100644 --- a/_scratch/Lines.hs +++ b/_scratch/Lines.hs @@ -15,7 +15,7 @@ instance (Append a) ⇒ Append (LinesPre a) where None → LinesPre (x₁ ⧺ x₂) sxs₂ Some (sxs₁' :꘍ (s₁ :꘍ x₁')) → LinesPre x₁ (sxs₁' ⧺ single (s₁ :꘍ x₁' ⧺ x₂) ⧺ sxs₂) instance (Monoid a) ⇒ Monoid (LinesPre a) -instance ToStream a (LinesPre a) where +instance ToStream a (LinesPre a) where stream (LinesPre x₀ sxs₀) = case stream sxs₀ of 𝑆 s₀ g → 𝑆 (Inl (x₀ :꘍ s₀)) $ \case Inl (x :꘍ s) → Some (x :꘍ Inr s) @@ -72,7 +72,7 @@ linesPreFromPost (LinesPost xss₀ x₀) = let (x₀' :꘍ sxs₀') = loop xss loop ∷ 𝑄 (a ∧ a) → a → (a ∧ 𝑄 (a ∧ a)) loop xss x = case unsnoc𝑄 xss of None → (x :꘍ null) - Some (xss' :꘍ (x' :꘍ s)) → + Some (xss' :꘍ (x' :꘍ s)) → let (y :꘍ sys) = loop xss' x' in (y :꘍ snoc𝑄 sys (s :꘍ x)) @@ -85,4 +85,3 @@ linesPostFromPre (LinesPre x₀ sxs₀) = let (xss₀' :꘍ x₀') = loop x₀ s Some ((s :꘍ x') :꘍ sxs') → let (yss :꘍ y) = loop x' sxs' in (cons𝑄 (x :꘍ s) yss :꘍ y) - diff --git a/_scratch/OldMatrix.hs b/_scratch/OldMatrix.hs index 719fd7e8..bddcd6c2 100644 --- a/_scratch/OldMatrix.hs +++ b/_scratch/OldMatrix.hs @@ -1,9 +1,9 @@ module UVMHS.Core.Matrix where -- -- vectors -- --- +-- -- data Bᴍ (m ∷ Tℕ) (n ∷ Tℕ) a where --- Bᴍ ∷ (Rℕ m,Rℕ n) +-- Bᴍ ∷ (Rℕ m,Rℕ n) -- ⇒ { rowsBᴍ ∷ Sℕ32 m -- , colsBᴍ ∷ Sℕ32 n -- , dataBᴍ ∷ Repa.Array Repa.V (Repa.Z Repa.:. HS.Int Repa.:. HS.Int) a @@ -23,168 +23,168 @@ module UVMHS.Core.Matrix where -- , dataVᴍ ∷ Repa.Array Repa.D (Repa.Z Repa.:. HS.Int Repa.:. HS.Int) a -- } -- → Vᴍ m n a --- +-- -- infixl 7 𝄪 --- class Matrix t where +-- class Matrix t where -- xrows ∷ t m n a → Sℕ32 m -- xcols ∷ t m n a → Sℕ32 n -- (𝄪) ∷ t m n a → (𝕀32 m,𝕀32 n) → a -- xvirt ∷ t m n a → Vᴍ m n a --- +-- -- -- boxed -- --- +-- -- indexBᴍ ∷ 𝕀32 m → 𝕀32 n → Bᴍ m n a → a -- indexBᴍ i j xs = Repa.unsafeIndex (dataBᴍ xs) (Repa.Z Repa.:. HS.fromIntegral (un𝕀32 i) Repa.:. HS.fromIntegral (un𝕀32 j)) --- +-- -- virtBᴍ ∷ Bᴍ m n a → Vᴍ m n a -- virtBᴍ (Bᴍ m n xs) = Vᴍ m n $ Repa.delay xs --- --- instance Matrix Bᴍ where +-- +-- instance Matrix Bᴍ where -- xrows = rowsBᴍ -- xcols = colsBᴍ -- xs 𝄪 (i,j) = indexBᴍ i j xs -- xvirt = virtBᴍ --- +-- -- -- unboxed -- --- +-- -- indexUᴍ ∷ 𝕀32 m → 𝕀32 n → Uᴍ m n a → a -- indexUᴍ i j (Uᴍ _ _ xs) = Repa.unsafeIndex xs (Repa.Z Repa.:. HS.fromIntegral (un𝕀32 i) Repa.:. HS.fromIntegral (un𝕀32 j)) --- +-- -- virtUᴍ ∷ Uᴍ m n a → Vᴍ m n a -- virtUᴍ (Uᴍ m n xs) = Vᴍ m n $ Repa.delay xs --- --- instance Matrix Uᴍ where +-- +-- instance Matrix Uᴍ where -- xrows = rowsUᴍ -- xcols = colsUᴍ -- xs 𝄪 (i,j) = indexUᴍ i j xs -- xvirt = virtUᴍ --- +-- -- -- virtual -- --- +-- -- indexVᴍ ∷ 𝕀32 m → 𝕀32 n → Vᴍ m n a → a --- indexVᴍ i j xs = Repa.unsafeIndex (dataVᴍ xs) (Repa.Z Repa.:. HS.fromIntegral (un𝕀32 i) Repa.:. HS.fromIntegral (un𝕀32 j)) --- +-- indexVᴍ i j xs = Repa.unsafeIndex (dataVᴍ xs) (Repa.Z Repa.:. HS.fromIntegral (un𝕀32 i) Repa.:. HS.fromIntegral (un𝕀32 j)) +-- -- instance Matrix Vᴍ where -- xrows = rowsVᴍ -- xcols = colsVᴍ -- xs 𝄪 (i,j) = indexVᴍ i j xs -- xvirt = id --- +-- -- matrix ∷ (Rℕ m,Rℕ n) ⇒ Sℕ32 m → Sℕ32 n → (𝕀32 m → 𝕀32 n → a) → Vᴍ m n a --- matrix m n f = --- Vᴍ m n $ Repa.fromFunction (Repa.Z Repa.:. HS.fromIntegral (unSℕ32 m) Repa.:. HS.fromIntegral (unSℕ32 n)) $ \ (Repa.Z Repa.:. i Repa.:. j) → --- d𝕟32 (HS.fromIntegral i) $ \ i' → +-- matrix m n f = +-- Vᴍ m n $ Repa.fromFunction (Repa.Z Repa.:. HS.fromIntegral (unSℕ32 m) Repa.:. HS.fromIntegral (unSℕ32 n)) $ \ (Repa.Z Repa.:. i Repa.:. j) → +-- d𝕟32 (HS.fromIntegral i) $ \ i' → -- d𝕟32 (HS.fromIntegral j) $ \ j' → -- f (𝕀32 i' TRUSTME_LT) (𝕀32 j' TRUSTME_LT) --- +-- -- xconst ∷ (Rℕ m,Rℕ n) ⇒ Sℕ32 m → Sℕ32 n → a → Vᴍ m n a -- xconst m n x = matrix m n $ \ _ _ → x --- +-- -- xbs ∷ Vᴍ m n a → Bᴍ m n a -- xbs (Vᴍ m n xs) = Bᴍ m n $ Repa.computeS xs --- +-- -- xbp ∷ Vᴍ m n a → Bᴍ m n a -- xbp (Vᴍ m n xs) = Bᴍ m n $ HS.runIdentity $ Repa.computeP xs --- +-- -- xus ∷ (Repa.Unbox a) ⇒ Vᴍ m n a → Uᴍ m n a -- xus (Vᴍ m n xs) = Uᴍ m n $ Repa.computeS xs --- +-- -- xup ∷ (Repa.Unbox a) ⇒ Vᴍ m n a → Uᴍ m n a -- xup (Vᴍ m n xs) = Uᴍ m n $ HS.runIdentity $ Repa.computeP xs --- +-- -- xiter ∷ Vᴍ m n a → 𝐼 a -- xiter xs = iter $ Repa.toList $ dataVᴍ xs --- +-- -- instance ToIter a (Bᴍ m n a) where iter = iter ∘ xvirt -- instance ToIter a (Uᴍ m n a) where iter = iter ∘ xvirt -- instance ToIter a (Vᴍ m n a) where iter = xiter --- +-- -- ------------- -- -- DERIVED -- -- ------------- --- +-- -- xtranspose ∷ Vᴍ m n a → Vᴍ n m a -- xtranspose xs@(Vᴍ _ _ _) = matrix (xcols xs) (xrows xs) $ \ j i → xs 𝄪 (i,j) --- +-- -- xmap ∷ (a → b) → Vᴍ m n a → Vᴍ m n b -- xmap f xs@(Vᴍ _ _ _) = matrix (xrows xs) (xcols xs) $ \ i j → f $ xs 𝄪 (i,j) --- +-- -- instance Functor (Vᴍ m n) where map = xmap --- +-- -- xmap2 ∷ (a → b → c) → Vᴍ m n a → Vᴍ m n b → Vᴍ m n c -- xmap2 f xs@(Vᴍ _ _ _) ys@(Vᴍ _ _ _) = matrix (xrows xs) (xcols xs) $ \ i j → f (xs 𝄪 (i,j)) (ys 𝄪 (i,j)) --- +-- -- xmeld ∷ (Rℕ n) ⇒ Sℕ32 n → Vᴍ m 1 (Vᴍ 1 n a) → Vᴍ m n a -- xmeld n xys@(Vᴍ _ _ _) = matrix (xrows xys) n $ \ i j → indexVᴍ (s𝕚 @ 0 P) j $ indexVᴍ i (s𝕚 @ 0 P) xys --- +-- -- xsplit ∷ Vᴍ m n a → Vᴍ m 1 (Vᴍ 1 n a) -- xsplit xys@(Vᴍ _ _ _) = matrix (xrows xys) (s𝕟32 @ 1) $ \ i _ → matrix (s𝕟32 @ 1) (colsVᴍ xys) $ \ _ j → indexVᴍ i j xys --- +-- -- xrow ∷ 𝕀32 m → Vᴍ m n a → Vᴍ 1 n a -- xrow i xs@(Vᴍ _ _ _) = matrix (s𝕟32 @ 1) (colsVᴍ xs) $ \ _ j → indexVᴍ i j xs --- +-- -- xcol ∷ 𝕀32 n → Vᴍ m n a → Vᴍ 1 m a -- xcol i xs = xrow i $ xtranspose xs --- +-- -- xproduct ∷ (Additive a,Times a) ⇒ Vᴍ m n a → Vᴍ n o a → Vᴍ m o a -- xproduct xs@(Vᴍ _ _ _) ys@(Vᴍ _ _ _) = -- matrix (xrows xs) (xcols ys) $ \ i k → -- let r₁ = xrow i xs -- r₂ = xcol k ys -- in sum $ iter $ xmap2 (×) r₁ r₂ --- +-- -- xbmapM ∷ (Monad m) ⇒ (a → m b) → Vᴍ n o a → m (Bᴍ n o b) -- xbmapM f xs@(Vᴍ _ _ _) = do -- xs' ← mapM (mapM f) $ xlist2 xs -- return $ xb xs' $ \ (Bᴍ _ _ xs'') → Bᴍ (xrows xs) (xcols xs) xs'' --- +-- -- xumapM ∷ (Monad m,Repa.Unbox a,Repa.Unbox b) ⇒ (a → m b) → Vᴍ n o a → m (Uᴍ n o b) -- xumapM f xs@(Vᴍ _ _ _) = do -- xs' ← mapM (mapM f) $ xlist2 xs -- return $ xu xs' $ \ (Uᴍ _ _ xs'') → Uᴍ (xrows xs) (xcols xs) xs'' --- +-- -- xindirect ∷ Vᴍ m n a → Vᴍ 1 o (𝕀32 m) → Vᴍ o n a -- xindirect xs@(Vᴍ _ _ _) is@(Vᴍ _ _ _) = matrix (xcols is) (xcols xs) $ \ o n → xs 𝄪 (is 𝄪 (s𝕚 @ 0 P,o),n) --- +-- -- xiter2 ∷ Vᴍ m n a → 𝐼 (𝐼 a) -- xiter2 = map iter ∘ iter ∘ xsplit --- +-- -- xlist2 ∷ Vᴍ m n a → 𝐿 (𝐿 a) -- xlist2 = list ∘ map list ∘ xiter2 --- +-- -- xb𝐼 ∷ 𝐼 (𝐼 a) → (∀ m n. (Rℕ m,Rℕ n) ⇒ Bᴍ m n a → b) → b -- xb𝐼 xs f = -- let uc = joins $ map (natΩ32 ∘ count) xs -- lc = meets $ map (AddTop ∘ natΩ32 ∘ count) xs -- in case AddTop uc ≡ lc of --- True → +-- True → -- d𝕟32 uc $ \ n → -- d𝕟32 (natΩ32 $ count xs) $ \ m → -- f $ Bᴍ m n $ Repa.fromList (Repa.Z Repa.:. HS.fromIntegral (unSℕ32 m) Repa.:. HS.fromIntegral (unSℕ32 n)) $ lazyList $ concat xs -- False → error "`xb𝐿`: bad input list: input list is either empty (no columns) or has columns of different length" --- +-- -- xb ∷ (ToIter a t,ToIter t u) ⇒ u → (∀ m n. (Rℕ m,Rℕ n) ⇒ Bᴍ m n a → b) → b -- xb xs f = xb𝐼 (map iter (iter xs)) f --- +-- -- xu𝐼 ∷ (Repa.Unbox a) ⇒ 𝐼 (𝐼 a) → (∀ m n. (Rℕ m,Rℕ n) ⇒ Uᴍ m n a → b) → b -- xu𝐼 xs f = -- let uc = joins $ map (natΩ32 ∘ count) xs -- lc = meets $ map (AddTop ∘ natΩ32 ∘ count) xs -- in case AddTop uc ≡ lc of --- True → +-- True → -- d𝕟32 uc $ \ n → -- d𝕟32 (natΩ32 $ count xs) $ \ m → -- f $ Uᴍ m n $ Repa.fromList (Repa.Z Repa.:. HS.fromIntegral (unSℕ32 m) Repa.:. HS.fromIntegral (unSℕ32 n)) $ lazyList $ concat xs -- False → error "`xb𝐿`: bad input list: input list is either empty (no columns) or has columns of different length" --- +-- -- xu ∷ (Repa.Unbox a,ToIter a t,ToIter t u) ⇒ u → (∀ m n. (Rℕ m,Rℕ n) ⇒ Uᴍ m n a → b) → b -- xu xs f = xu𝐼 (map iter (iter xs)) f --- +-- -- instance (Times a) ⇒ Times (Vᴍ m n a) where (×) = xmap2 (×) --- +-- -- (✖) ∷ (Additive a,Times a) ⇒ Vᴍ m n a → Vᴍ n o a → Vᴍ m o a -- (✖) = xproduct --- +-- -- testMatrix1 ∷ IO () -- testMatrix1 = do -- let xs = list [list [1,2,3],list [4,5,6],list [7,8,9]] @@ -192,5 +192,4 @@ module UVMHS.Core.Matrix where -- xb xs $ \ xs' → do -- let ys = xlist2 $ xtranspose $ xvirt xs' -- shout ys --- - +-- diff --git a/_scratch/OldNewVector.hs b/_scratch/OldNewVector.hs index fe5e209a..5b8d9c4e 100644 --- a/_scratch/OldNewVector.hs +++ b/_scratch/OldNewVector.hs @@ -3,91 +3,91 @@ -------- -- newtype 𝕄S m n a = 𝕄S_UNSAFE { un𝕄S ∷ M.Matrix a } --- +-- -- deriving instance (M.Container M.Matrix a) ⇒ Eq (𝕄S m n a) --- +-- -- instance (Element a) ⇒ ToStream a (𝕄S m n a) where {-# INLINE stream #-} ; stream = stream𝕄S -- instance (Element a) ⇒ ToIter a (𝕄S m n a) where {-# INLINE iter #-} ; iter = iter ∘ stream -- instance (Element a,Show a) ⇒ Show (𝕄S m n a) where {-# INLINE show #-} ; show = chars ∘ show𝕄S -- instance (M.Container M.Matrix a) ⇒ Access (𝕀64 m,𝕀64 n) a (𝕄S m n a) where {-# INLINE (⋕) #-} ; (⋕) = flip $ curry idx𝕄S ∘ frhs -- instance (𝒩 m,𝒩 n,M.Container M.Matrix a) ⇒ Lookup (ℕ64,ℕ64) a (𝕄S m n a) where {-# INLINE (⋕?) #-} ; (⋕?) = flip $ curry idxChecked𝕄S ∘ frhs -- instance (𝒩 m,𝒩 n,Element a,Null a) ⇒ Null (𝕄S m n a) where {-# INLINE null #-} ; null = null𝕄S --- +-- -- {-# INLINE smat #-} -- smat ∷ ∀ m n a. (𝒩 m,𝒩 n,Element a) ⇒ 𝐼S m (𝐼S n a) → 𝕄S m n a -- smat xs = 𝕄S_UNSAFE $ ((tohs $ intΩ64 $ unℕ64S $ 𝕟64s @ m) M.>< (tohs $ intΩ64 $ unℕ64S $ 𝕟64s @ n)) $ lazyList $ concat $ un𝐼S $ map un𝐼S xs --- +-- -- {-# INLINE smatF #-} -- smatF ∷ ∀ m n a. (𝒩 m,𝒩 n,Element a) ⇒ (𝕀64 m → 𝕀64 n → a) → 𝕄S m n a -- smatF f = smat $ mapOn upTo𝕀64 $ \ i → mapOn upTo𝕀64 $ \ j → f i j --- +-- -- {-# INLINE idx𝕄S #-} -- idx𝕄S ∷ (M.Container M.Matrix a) ⇒ 𝕀64 m → 𝕀64 n → 𝕄S m n a → a -- idx𝕄S i j xs = M.atIndex (un𝕄S xs) (tohs $ intΩ64 $ un𝕀64 i,tohs $ intΩ64 $ un𝕀64 j) --- +-- -- {-# INLINE idxChecked𝕄S #-} -- idxChecked𝕄S ∷ ∀ m n a. (𝒩 m,𝒩 n,M.Container M.Matrix a) ⇒ ℕ64 → ℕ64 → 𝕄S m n a → 𝑂 a -- idxChecked𝕄S i j xs = do -- i' ← 𝕚64d i -- j' ← 𝕚64d j -- return $ idx𝕄S i' j' xs --- +-- -- {-# INLINE iter𝕄S #-} -- iter𝕄S ∷ (Element a) ⇒ 𝕄S m n a → 𝐼S m (𝐼S n a) -- iter𝕄S xs = map (𝐼S_UNSAFE ∘ iter) $ 𝐼S_UNSAFE $ iter $ M.toLists $ un𝕄S xs --- +-- -- {-# INLINE stream𝕄S #-} -- stream𝕄S ∷ (Element a) ⇒ 𝕄S m n a → 𝑆 a -- stream𝕄S xs = stream $ M.toList $ M.flatten $ un𝕄S xs --- +-- -- {-# INLINE show𝕄S #-} -- show𝕄S ∷ (Element a,Show a) ⇒ 𝕄S m n a → 𝕊 -- show𝕄S = showCollection "𝕄S[" "]" "," show𝕊 ∘ iter --- +-- -- {-# INLINE null𝕄S #-} -- null𝕄S ∷ (𝒩 m,𝒩 n,Element a,Null a) ⇒ 𝕄S m n a -- null𝕄S = smatF $ const $ const null --- +-- -- {-# INLINE map𝕄S #-} -- map𝕄S ∷ (𝒩 m,𝒩 n,Element a,Element b) ⇒ (a → b) → 𝕄S m n a → 𝕄S m n b -- map𝕄S f = smat ∘ mapp f ∘ iter𝕄S --- +-- -- {-# INLINE (✖) #-} -- (✖) ∷ (M.Numeric a) ⇒ 𝕄S m n a → 𝕄S n o a → 𝕄S m o a -- xs ✖ ys = 𝕄S_UNSAFE $ un𝕄S xs M.<> un𝕄S ys --- +-- -- {-# INLINE (✖♯) #-} -- (✖♯) ∷ (M.Numeric a) ⇒ 𝕄S m n a → 𝕌S n a → 𝕌S m a -- xs ✖♯ ys = 𝕌S_UNSAFE $ un𝕄S xs M.#> un𝕌S ys --- +-- -- {-# INLINE (♯✖) #-} -- (♯✖) ∷ (M.Numeric a) ⇒ 𝕌S m a → 𝕄S m n a → 𝕌S n a -- xs ♯✖ ys = 𝕌S_UNSAFE $ un𝕌S xs M.<# un𝕄S ys --- +-- -- {-# INLINE 𝐭 #-} -- 𝐭 ∷ (M.Transposable (M.Matrix a) (M.Matrix a)) ⇒ 𝕄S m n a → 𝕄S n m a -- 𝐭 xs = 𝕄S_UNSAFE $ M.tr $ un𝕄S xs --- +-- -- {-# INLINE mrow #-} -- mrow ∷ (Storable a) ⇒ 𝕌S n a → 𝕄S 1 n a -- mrow xs = 𝕄S_UNSAFE $ M.asRow $ un𝕌S xs --- +-- -- {-# INLINE mcol #-} -- mcol ∷ (Storable a) ⇒ 𝕌S n a → 𝕄S n 1 a -- mcol xs = 𝕄S_UNSAFE $ M.asColumn $ un𝕌S xs --- +-- -- {-# INLINE plus𝕄S #-} -- plus𝕄S ∷ (M.Container M.Matrix a,HS.Num (M.Vector a),HS.Num a) ⇒ 𝕄S m n a → 𝕄S m n a → 𝕄S m n a -- plus𝕄S xs ys = 𝕄S_UNSAFE $ un𝕄S xs HS.+ un𝕄S ys --- +-- -- {-# INLINE times𝕄S #-} -- times𝕄S ∷ (M.Container M.Matrix a,HS.Num (M.Vector a),HS.Num a) ⇒ 𝕄S m n a → 𝕄S m n a → 𝕄S m n a -- times𝕄S xs ys = 𝕄S_UNSAFE $ un𝕄S xs HS.+ un𝕄S ys --- +-- -- {-# INLINE div𝕄S #-} -- div𝕄S ∷ (M.Container M.Matrix a,HS.Num (M.Vector a),HS.Num a) ⇒ 𝕄S m n a → 𝕄S m n a → 𝕄S m n a -- div𝕄S xs ys = 𝕄S_UNSAFE $ un𝕄S xs HS.+ un𝕄S ys --- +-- -- instance (M.Container M.Matrix a,HS.Num (M.Vector a),HS.Num a) ⇒ Plus (𝕄S m n a) where {-# INLINE (+) #-} ; (+) = plus𝕄S -- instance (M.Container M.Matrix a,HS.Num (M.Vector a),HS.Num a) ⇒ Times (𝕄S m n a) where {-# INLINE (×) #-} ; (×) = times𝕄S -- instance (M.Container M.Matrix a,HS.Num (M.Vector a),HS.Num a) ⇒ Divide (𝕄S m n a) where {-# INLINE (/) #-} ; (/) = div𝕄S @@ -95,26 +95,25 @@ -- ------- -- -- 𝕄 -- -- ------- --- +-- -- newtype 𝕄 (ns ∷ [𝐍]) (a ∷ ★) = 𝕄 { un𝕄 ∷ 𝕌S (Prod ns) a } --- +-- -- idx𝕄I ∷ 𝐿S ns ℕ64S → 𝐿S ns 𝕀64 → ℕ64S (Prod ns) ∧ 𝕀64 (Prod ns) -- idx𝕄I ns is = case (ns,is) of -- (NilS,NilS) → oneS :* 𝕚64 zeroS --- ((n ∷ ℕ64S n) :&& (ns' ∷ 𝐿S ns' ℕ64S),(i ∷ 𝕀64 n) :&& (is' ∷ 𝐿S ns' 𝕀64)) → +-- ((n ∷ ℕ64S n) :&& (ns' ∷ 𝐿S ns' ℕ64S),(i ∷ 𝕀64 n) :&& (is' ∷ 𝐿S ns' 𝕀64)) → -- let n' :* i' = idx𝕄I ns' is' -- in -- -- want i * (prod ns) + idx𝕄I is --- 𝕟64di i $ \ (ni ∷ ℕ64S ni) → +-- 𝕟64di i $ \ (ni ∷ ℕ64S ni) → -- -- ni < n -- 𝕟64di i' $ \ (nis' ∷ ℕ64S nis') → -- -- is' < Prod ns -- let i'' ∷ ℕ64S (ni × Prod ns' + nis') -- i'' = ni ×♮ n' +♮ nis' --- in +-- in -- with (wnlt_UNSAFE @ (ni × Prod ns' + nis') @ (n × Prod ns') P P) $ -- (n ×♮ n') :* 𝕚64 i'' --- +-- -- idx𝕄 ∷ (Storable a) ⇒ 𝐿S ns ℕ64S → 𝐿S ns 𝕀64 → 𝕌S (Prod ns) a → a -- idx𝕄 ns is xs = xs ⋕ snd (idx𝕄I ns is) - diff --git a/_scratch/OldParserContext.hs b/_scratch/OldParserContext.hs index 04acebb0..6156d114 100644 --- a/_scratch/OldParserContext.hs +++ b/_scratch/OldParserContext.hs @@ -6,23 +6,23 @@ module UVMHS.Lib.Parser.ParserContext where -- import UVMHS.Lib.Parser.Sep -- -- # ParserContextDoc --- +-- -- data ParserContextMode = ParserContextDisplay | ParserContextError -- deriving (Eq,Ord) --- +-- -- newtype ParserContextDoc = ParserContextDoc { runParserContextDoc ∷ RWS ParserContextMode Doc () () } -- deriving (Null,Append,Monoid) -- instance Pretty ParserContextDoc where pretty = execParserContextDoc --- +-- -- onParserContextDoc ∷ (RWS ParserContextMode Doc () () → RWS ParserContextMode Doc () ()) → ParserContextDoc → ParserContextDoc -- onParserContextDoc f = ParserContextDoc ∘ f ∘ runParserContextDoc --- +-- -- execParserContextDoc ∷ ParserContextDoc → Doc -- execParserContextDoc = evalRWS ParserContextDisplay () ∘ retOut ∘ runParserContextDoc --- +-- -- parserContextError ∷ ParserContextDoc → ParserContextDoc -- parserContextError = onParserContextDoc $ local ParserContextError --- +-- -- data ParserContextDocCached = ParserContextDocCached -- { parserContextDocCachedDoc ∷ ParserContextDoc -- -- , parserContextDocCachedBytes ∷ 𝑄 OutputElemNF @@ -30,24 +30,24 @@ module UVMHS.Lib.Parser.ParserContext where -- instance Eq ParserContextDocCached where (==) = (≡) `on` (ppRenderWide ∘ execParserContextDoc ∘ parserContextDocCachedDoc) -- (≡) `on` parserContextDocCachedBytes -- instance Ord ParserContextDocCached where compare = (⋚) `on` (ppRenderWide ∘ execParserContextDoc ∘ parserContextDocCachedDoc) -- parserContextDocCachedBytes -- instance Null ParserContextDocCached where null = mkParserContextDocCached null --- instance Append ParserContextDocCached where +-- instance Append ParserContextDocCached where -- ParserContextDocCached d₁ {- b₁ -} ⧺ ParserContextDocCached d₂ {- b₂ -} = ParserContextDocCached (d₁ ⧺ d₂) -- (b₁ ⧺ b₂) -- instance Monoid ParserContextDocCached --- instance Pretty ParserContextDocCached where +-- instance Pretty ParserContextDocCached where -- pretty x = concat -- [ ppString "«" -- , pretty $ parserContextDocCachedDoc x -- , ppString "»" -- ] --- +-- -- mkParserContextDocCached ∷ ParserContextDoc → ParserContextDocCached -- mkParserContextDocCached doc = ParserContextDocCached doc -- (prettyNFDoc $ execParserContextDoc doc) --- +-- -- onParserContextDocCached ∷ (RWS ParserContextMode Doc () () → RWS ParserContextMode Doc () ()) → ParserContextDocCached → ParserContextDocCached -- onParserContextDocCached f = mkParserContextDocCached ∘ onParserContextDoc f ∘ parserContextDocCachedDoc --- +-- -- -- # ParserContextLines --- +-- -- data ParserContextChunk = ParserContextChunk -- { parserContextChunkLocRange ∷ AddBot LocRange -- , parserContextChunkNewlines ∷ ℕ @@ -57,16 +57,16 @@ module UVMHS.Lib.Parser.ParserContext where -- deriving (Eq,Ord) -- makeLenses ''ParserContextChunk -- makePrettySum ''ParserContextChunk --- +-- -- instance Null ParserContextChunk where null = ParserContextChunk bot zero null --- instance Append ParserContextChunk where --- ParserContextChunk r₁ n₁ d₁ ⧺ ParserContextChunk r₂ n₂ d₂ = ParserContextChunk (r₁ ⊔ r₂) (n₁ + n₂) (d₁ ⧺ d₂) +-- instance Append ParserContextChunk where +-- ParserContextChunk r₁ n₁ d₁ ⧺ ParserContextChunk r₂ n₂ d₂ = ParserContextChunk (r₁ ⊔ r₂) (n₁ + n₂) (d₁ ⧺ d₂) -- instance Monoid ParserContextChunk --- +-- -- type ContextLines = SepR ParserContextChunk ParserContextChunk --- +-- -- -- # ParserContext --- +-- -- data ParserContext = ParserContext -- { parserContextLocRange ∷ AddBot LocRange -- , parserContextNewlines ∷ ℕ @@ -75,28 +75,28 @@ module UVMHS.Lib.Parser.ParserContext where -- deriving (Eq,Ord) -- makeLenses ''ParserContext -- makePrettySum ''ParserContext --- +-- -- instance Null ParserContext where null = parserContextFromLines null -- instance Append ParserContext where ParserContext l₁ n₁ s₁ ⧺ ParserContext l₂ n₂ s₂ = ParserContext (l₁ ⊔ l₂) (n₁ + n₂) (s₁ ⧺ s₂) -- instance Monoid ParserContext --- +-- -- onParserContext ∷ (RWS ParserContextMode Doc () () → RWS ParserContextMode Doc () ()) → ParserContext → ParserContext -- onParserContext = alter parserContextLinesL ∘ map ∘ alter parserContextChunkDocL ∘ onParserContextDocCached --- +-- -- execParserContext ∷ ParserContext → ParserContextDoc -- execParserContext = concat ∘ map (parserContextDocCachedDoc ∘ parserContextChunkDoc) ∘ iter ∘ parserContextLines --- +-- -- parserContextFromLines ∷ ContextLines → ParserContext -- parserContextFromLines pcl₀ = let (lr,n) = parserContextLinesMeta pcl₀ in ParserContext lr n pcl₀ -- where --- parserContextLinesMeta pcl = +-- parserContextLinesMeta pcl = -- ( joins $ map parserContextChunkLocRange $ iter pcl -- , sum $ map parserContextChunkNewlines $ iter pcl -- ) --- +-- -- truncateParserContext ∷ ℕ → ParserContext → ParserContext -- truncateParserContext n (ParserContext _lr _n l) = parserContextFromLines $ lastNSepR n l --- +-- -- newtype InputContext = InputContext { unInputContext ∷ ParserContext } -- deriving (Eq,Ord,Null,Append,Monoid) -- makePrettySum ''InputContext diff --git a/_scratch/OldPretty2/Class.hs b/_scratch/OldPretty2/Class.hs index a49e625a..5c98d041 100644 --- a/_scratch/OldPretty2/Class.hs +++ b/_scratch/OldPretty2/Class.hs @@ -43,14 +43,14 @@ escape = \case '\f' → iter "\\f" c' → single c' -instance Pretty ℂ where +instance Pretty ℂ where pretty c = ppLit $ string $ concat [ iter "'" , escape c , iter "'" ] -instance Pretty 𝕊 where +instance Pretty 𝕊 where pretty s = ppLit $ string $ concat [ iter "\"" , escape *$ iter s diff --git a/_scratch/OldPretty2/Color.hs b/_scratch/OldPretty2/Color.hs index 29ae93c5..5e226903 100644 --- a/_scratch/OldPretty2/Color.hs +++ b/_scratch/OldPretty2/Color.hs @@ -12,7 +12,7 @@ data Color3Bit = | Cyan | White deriving (Eq,Ord,Show) -data Color = +data Color = Color Color3Bit | Color8 ℕ8 | Color24 ℕ8 ℕ8 ℕ8 @@ -44,7 +44,7 @@ lightGray = Color8 $ 𝕟8 15 highlight = Color8 $ 𝕟8 229 -data Format = +data Format = FG Color | NOFG | BG Color @@ -66,7 +66,7 @@ data Formats = Formats } deriving (Eq,Ord,Show) instance Null Formats where null = Formats None None None None None instance Append Formats where - Formats fg₁ bg₁ ul₁ bd₁ it₁ ⧺ Formats fg₂ bg₂ ul₂ bd₂ it₂ = + Formats fg₁ bg₁ ul₁ bd₁ it₁ ⧺ Formats fg₂ bg₂ ul₂ bd₂ it₂ = Formats (first fg₁ fg₂) (first bg₁ bg₂) (first ul₁ ul₂) (first bd₁ bd₂) (first it₁ it₂) instance Monoid Formats diff --git a/_scratch/OldPretty2/Console.hs b/_scratch/OldPretty2/Console.hs index 8dfcfdc1..82a9fbf4 100644 --- a/_scratch/OldPretty2/Console.hs +++ b/_scratch/OldPretty2/Console.hs @@ -11,13 +11,13 @@ data ConsoleEnv = ConsoleEnv makeLenses ''ConsoleEnv consoleEnv₀ ∷ ConsoleEnv -consoleEnv₀ = ConsoleEnv +consoleEnv₀ = ConsoleEnv { ρUnderFormat = None , ρLineNumberWidth = 0 } data ConsoleOut = - NullCO + NullCO | ChunkCO 𝕊 | AppendCO ConsoleOut ConsoleOut | FormatCO Formats ConsoleOut @@ -81,7 +81,7 @@ doUnders = do eachOn (reverse us) $ \ (colₗ :* colᵤ :* f :* c) → do col ← getL σColL spitConsole $ string $ repeat (colₗ - col) ' ' - mapOut (FormatCO f) $ + mapOut (FormatCO f) $ spitConsole $ string $ repeat (colᵤ - colₗ) c putL σUndersL $ list [] @@ -105,9 +105,9 @@ interpOutput ∷ Output → ConsoleM () interpOutput = exec ∘ map interpOutputElem ∘ iter execPrettyOut ∷ PrettyOut → ConsoleOut -execPrettyOut (PrettyOut o ln) = - evalConsoleM consoleEnv₀ consoleState₀ - $ retOut +execPrettyOut (PrettyOut o ln) = + evalConsoleM consoleEnv₀ consoleState₀ + $ retOut $ finalize - $ mapEnv (update ρLineNumberWidthL ln) + $ mapEnv (update ρLineNumberWidthL ln) $ interpOutput o diff --git a/_scratch/OldPretty2/ConsoleANSI.hs b/_scratch/OldPretty2/ConsoleANSI.hs index 335cd491..6d5d7b25 100644 --- a/_scratch/OldPretty2/ConsoleANSI.hs +++ b/_scratch/OldPretty2/ConsoleANSI.hs @@ -70,7 +70,7 @@ sgrIt False = "23" sgrFormat ∷ Formats → 𝑄 𝕊 sgrFormat (Formats fg bg ul bd it) = single $ concat - [ sgrLeader + [ sgrLeader , concat $ inbetween ";" $ list $ mconcat $ map (mzero𝑂 @ 𝑄) [ sgrFg ^$ fg , sgrBg ^$ bg diff --git a/_scratch/OldPretty2/ConsoleHTML.hs b/_scratch/OldPretty2/ConsoleHTML.hs index 3ac10b8a..a7df6032 100644 --- a/_scratch/OldPretty2/ConsoleHTML.hs +++ b/_scratch/OldPretty2/ConsoleHTML.hs @@ -33,11 +33,11 @@ htmlFGCode c s = concat htmlBGCode ∷ 𝑂 Color → 𝑄 𝕊 → 𝑄 𝕊 htmlBGCode c s = concat [ single $ concat - [ "" ] - , s + , s , single "" ] diff --git a/_scratch/OldPretty2/Core.hs b/_scratch/OldPretty2/Core.hs index a00b4084..938d774d 100644 --- a/_scratch/OldPretty2/Core.hs +++ b/_scratch/OldPretty2/Core.hs @@ -86,7 +86,7 @@ prettyEnv₀ = PrettyEnv data Chunk = LineNumber ℕ | Text 𝕊 | Newline deriving (Eq, Ord,Show) -data Annotation = +data Annotation = FormatA (𝐿 Format) | UndertagA (𝑂 (𝐿 Format ∧ ℂ)) deriving (Eq,Ord,Show) @@ -102,7 +102,7 @@ data PrettyOut = PrettyOut } deriving (Eq,Ord,Show) makeLenses ''PrettyOut instance Null PrettyOut where null = PrettyOut null 0 -instance Append PrettyOut where PrettyOut o₁ n₁ ⧺ PrettyOut o₂ n₂ = PrettyOut (o₁ ⧺ o₂) (n₁ ⊔ n₂) +instance Append PrettyOut where PrettyOut o₁ n₁ ⧺ PrettyOut o₂ n₂ = PrettyOut (o₁ ⧺ o₂) (n₁ ⊔ n₂) instance Monoid PrettyOut ----------------- @@ -172,7 +172,7 @@ shouldOutputNewline = do Some (low :* high) → (low ≤ ln) ⩓ (ln < high) spit ∷ 𝕊 → PrettyM () -spit s = +spit s = let l = length𝕊 s c = countWith (not ∘ isSpace) s o = single $ RawChunk $ Text s @@ -184,7 +184,7 @@ spit s = annotateOutput ∷ Annotation → Output → PrettyM Output annotateOutput a o = do df ← askL doFormatL - return $ case df of + return $ case df of True → single $ AnnotatedOutput a o False → o @@ -195,9 +195,9 @@ doLineNumber b = do lnf ← askL $ lineNumberFormatL ⊚ prettyParamsL dln ← getL displayLineNumberL whenM shouldOutput $ \ () → do - tellL outputL - *$ annotateOutput (FormatA (lnf ⧺ override)) - *$ annotateOutput (UndertagA None) + tellL outputL + *$ annotateOutput (FormatA (lnf ⧺ override)) + *$ annotateOutput (UndertagA None) *$ return $ single $ RawChunk $ LineNumber dln tellL maxDisplayLineNumberL $ length𝕊 $ show𝕊 dln @@ -208,17 +208,17 @@ doNesting b = do o :* () ← hijackL outputL $ do -- spit $ build𝕊 $ repeat n " " modifyL columnL $ (+) n - whenM shouldOutput $ \ () → + whenM shouldOutput $ \ () → tellL outputL $ single $ RawChunk $ Text $ string $ repeat n ' ' - tellL outputL - *$ annotateOutput (FormatA override) + tellL outputL + *$ annotateOutput (FormatA override) *$ annotateOutput (UndertagA None) *$ return o word ∷ 𝕊 → PrettyM () word s | isEmpty𝕊 s = skip -word s = - let cmd = spit s +word s = + let cmd = spit s in do b ← getputL beginningL False doLineNumber b @@ -448,10 +448,10 @@ ppCollection open close sep xs = ppGroup $ ppBotLevel $ ppIfFlat flatCollection where flatCollection = concat [ppPun open,concat $ inbetween (ppPun sep) xs,ppPun close] breakCollection = ppVertical $ concat - [ list - $ mapFirst (\ x → ppHorizontal $ list [ppPun open,x]) - $ mapAfterFirst (\ x → ppHorizontal $ list [ppPun sep,x]) - $ map ppAlign + [ list + $ mapFirst (\ x → ppHorizontal $ list [ppPun open,x]) + $ mapAfterFirst (\ x → ppHorizontal $ list [ppPun sep,x]) + $ map ppAlign $ iter xs , return $ ppPun close ] diff --git a/_scratch/OldPretty2/Deriving.hs b/_scratch/OldPretty2/Deriving.hs index a45b62ba..d522619b 100644 --- a/_scratch/OldPretty2/Deriving.hs +++ b/_scratch/OldPretty2/Deriving.hs @@ -8,8 +8,8 @@ import qualified Language.Haskell.TH as TH import qualified Data.Text as Text --- makePrettySumLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] [(con₁,[conty₁₁,…,conty₁⸤n₁⸥]),…,(conₘ,[contyₘ₁,…,contyₘ⸤nₘ⸥])] ≔ --- [| instance +-- makePrettySumLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] [(con₁,[conty₁₁,…,conty₁⸤n₁⸥]),…,(conₘ,[contyₘ₁,…,contyₘ⸤nₘ⸥])] ≔ +-- [| instance -- (C₁,…,Cₙ -- ,Pretty conty₁₁,…,Pretty conty₁⸤n₁⸥,…,Pretty contyₘ₁,…,Pretty contyₘ⸤nₘ⸥ -- ) ⇒ Pretty (ty a₁ … aₙ) where @@ -25,7 +25,7 @@ makePrettySumLogic cx ty tyargs concontys = do let tyargVars ∷ 𝐿 TH.Type tyargVars = map (TH.VarT ∘ thTyVarBndrName) tyargs instanceCx ∷ 𝐿 TH.Pred - instanceCx = list $ uniques $ concat + instanceCx = list $ uniques $ concat [ frhs cx , map (\ x → TH.ConT ''Pretty ⊙ x) $ concat $ map snd $ concontys ] @@ -45,8 +45,8 @@ makePrettySum name = do scs ← mapM (return𝑂 (io abortIO) ∘ thViewSimpleCon) cs map tohs $ makePrettySumLogic cx ty tyargs scs --- makePrettyUnionLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] [(con₁,[conty₁₁,…,conty₁⸤n₁⸥]),…,(conₘ,[contyₘ₁,…,contyₘ⸤nₘ⸥])] ≔ --- [| instance +-- makePrettyUnionLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] [(con₁,[conty₁₁,…,conty₁⸤n₁⸥]),…,(conₘ,[contyₘ₁,…,contyₘ⸤nₘ⸥])] ≔ +-- [| instance -- (C₁,…,Cₙ -- ,Pretty conty₁₁,…,Pretty conty₁⸤n₁⸥,…,Pretty contyₘ₁,…,Pretty contyₘ⸤nₘ⸥ -- ) ⇒ Pretty (ty a₁ … aₙ) where @@ -65,11 +65,11 @@ makePrettyUnionLogic cx ty tyargs concontys = do instanceTy ∷ TH.Type instanceTy = TH.ConT ''Pretty ⊙ (TH.ConT ty ⊙⋆ tyargVars) instanceDec ∷ TH.Dec - instanceDec = TH.FunD 'pretty $ tohs $ mapOn conxs $ \ (con :* tmpˣˢ) → + instanceDec = TH.FunD 'pretty $ tohs $ mapOn conxs $ \ (con :* tmpˣˢ) → thSingleClause (single $ TH.ConP con $ tohs $ map TH.VarP tmpˣˢ) $ case tmpˣˢ of Nil → TH.VarE 'pretty ⊙ TH.ConE '() x :& Nil → TH.VarE 'pretty ⊙ TH.VarE x - _ → + _ → let prettyXs = mapOn tmpˣˢ $ \ x → TH.VarE 'pretty ⊙ TH.VarE x in TH.VarE 'ppCollection ⊙ thString "⟨" ⊙ thString "⟩" ⊙ thString "," ⊙$ TH.VarE 'list ⊙$ TH.ListE (tohs prettyXs) return $ single $ TH.InstanceD (tohs None) (tohs instanceCx) instanceTy $ single $ instanceDec @@ -81,7 +81,7 @@ makePrettyUnion name = do map tohs $ makePrettyUnionLogic cx ty tyargs scs -- makePrettyRecordLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] con [(field₁,fieldty₁),…,(fieldₙ,fieldtyₙ)] ≔ --- [| instance +-- [| instance -- (C₁,…,Cₙ -- ,Pretty fieldty₁,…,Pretty fieldtyₙ -- ) ⇒ Pretty (ty a₁ … aₙ) where @@ -97,16 +97,16 @@ makePrettyRecordLogic cx ty tyargs con fieldfieldtys = do return (field :* loweredAfterPrefix :* tmpˣ) let tyargVars = map (TH.VarT ∘ thTyVarBndrName) tyargs instanceCx ∷ 𝐿 TH.Pred - instanceCx = list $ uniques $ concat + instanceCx = list $ uniques $ concat [ frhs cx , map (\ x → TH.ConT ''Pretty ⊙ x) $ map snd fieldfieldtys ] instanceTy ∷ TH.Type instanceTy = TH.ConT ''Pretty ⊙ (TH.ConT ty ⊙⋆ tyargVars) instanceDec ∷ TH.Dec - instanceDec = - TH.FunD 'pretty $ single $ thSingleClause - (single $ TH.RecP con $ tohs $ mapOn fieldNameTmps $ \ (field :* _name :* tmpˣ) → (field :* TH.VarP tmpˣ)) + instanceDec = + TH.FunD 'pretty $ single $ thSingleClause + (single $ TH.RecP con $ tohs $ mapOn fieldNameTmps $ \ (field :* _name :* tmpˣ) → (field :* TH.VarP tmpˣ)) $ TH.VarE 'ppApp ⊙ (TH.VarE 'ppCon ⊙ (thString $ string $ TH.nameBase con)) ⊙$ TH.VarE 'list ⊙$ TH.ListE $ single $ TH.VarE 'ppRecord ⊙ thString "≔" ⊙$ TH.VarE 'list ⊙$ TH.ListE $ tohs $ mapOn fieldNameTmps $ \ (frhs → _field :* name :* tmpˣ) → TH.ConE '(:*) diff --git a/_scratch/OldPretty2/Examples.hs b/_scratch/OldPretty2/Examples.hs index 5feecfcc..38485cd4 100644 --- a/_scratch/OldPretty2/Examples.hs +++ b/_scratch/OldPretty2/Examples.hs @@ -54,7 +54,7 @@ testPrettyLineNumbers = ppVertical $ list ] testPrettyBlinders ∷ Doc -testPrettyBlinders = +testPrettyBlinders = let lines ∷ 𝐿 Doc lines = list $ map (\ (i :* p) → ppHorizontal $ list [p,ppNoFormat $ pretty i]) $ withIndex $ repeat 30 (ppText "line number") in ppLineNumbers $ ppBlinders 10 20 $ ppVertical $ lines diff --git a/_scratch/OldPretty2/NF.hs b/_scratch/OldPretty2/NF.hs index 969135d5..68aefbc1 100644 --- a/_scratch/OldPretty2/NF.hs +++ b/_scratch/OldPretty2/NF.hs @@ -11,7 +11,7 @@ data NFEnv = NFEnv } makeLenses ''NFEnv -data OutputElemNF = +data OutputElemNF = LineNumberNF Formats ℕ | CharNF Formats (𝑂 (ℂ ∧ Formats)) ℂ | NewlineNF @@ -33,7 +33,7 @@ annotatedOutputNF ∷ Annotation → Output → ReaderT NFEnv 𝑄 OutputElemNF annotatedOutputNF a o = case a of FormatA fmts → do mapEnvL nfformatsL ((⧺) $ concat $ map formats $ iter fmts) $ outputNF o - UndertagA fmtscO → + UndertagA fmtscO → let f = case fmtscO of None → None Some (fmts :* c) → Some (c :* (concat $ map formats $ iter fmts)) diff --git a/_scratch/OldSep.hs b/_scratch/OldSep.hs index cadd2a7c..f19d2cc7 100644 --- a/_scratch/OldSep.hs +++ b/_scratch/OldSep.hs @@ -23,7 +23,7 @@ swivelR (x :& xs) y = -- SepL -- ---------- -data SepL i a = +data SepL i a = SepLSingle a | SepLMulti ℕ64 a (𝐼 (i ∧ a)) i a deriving (Show) @@ -36,7 +36,7 @@ eSepL x = SepLSingle x iSepL ∷ (Null a) ⇒ i → SepL i a iSepL i = SepLMulti one null null i null -instance (Null a) ⇒ Null (SepL i a) where +instance (Null a) ⇒ Null (SepL i a) where -- {-# INLINE null #-} null = SepLSingle null instance (Append a) ⇒ Append (SepL i a) where @@ -44,11 +44,11 @@ instance (Append a) ⇒ Append (SepL i a) where SepLSingle x₁ ⧺ SepLSingle x₂ = SepLSingle $ x₁ ⧺ x₂ SepLSingle x₁ ⧺ SepLMulti n x₂ ixs₂ i₂ y₂ = SepLMulti n (x₁ ⧺ x₂) ixs₂ i₂ y₂ SepLMulti n x₁ ixs₁ i₁ y₁ ⧺ SepLSingle x₂ = SepLMulti n x₁ ixs₁ i₁ (y₁ ⧺ x₂) - SepLMulti n₁ x₁ ixs₁ i₁ y₁ ⧺ SepLMulti n₂ x₂ ixs₂ i₂ y₂ = + SepLMulti n₁ x₁ ixs₁ i₁ y₁ ⧺ SepLMulti n₂ x₂ ixs₂ i₂ y₂ = SepLMulti (n₁ + n₂) x₁ (ixs₁ ⧺ single (i₁ :* (y₁ ⧺ x₂)) ⧺ ixs₂) i₂ y₂ instance (Monoid a) ⇒ Monoid (SepL i a) -instance ToIter a (SepL a a) where +instance ToIter a (SepL a a) where -- {-# INLINE iter #-} iter (SepLSingle x) = single x iter (SepLMulti _ x ixs i y) = concat @@ -57,7 +57,7 @@ instance ToIter a (SepL a a) where , iter [i,y] ] -instance (Pretty a) ⇒ Pretty (SepL a a) where +instance (Pretty a) ⇒ Pretty (SepL a a) where -- {-# INLINE pretty #-} pretty = concat ∘ map pretty ∘ iter @@ -84,7 +84,7 @@ sepsCountL (SepLMulti n _ _ _ _) = n -- SepR -- ---------- -data SepR i a = +data SepR i a = SepRSingle a | SepRMulti ℕ64 a i (𝐼 (a ∧ i)) a deriving (Show) @@ -97,7 +97,7 @@ eSepR x = SepRSingle x iSepR ∷ (Null a) ⇒ i → SepR i a iSepR i = SepRMulti one null i null null -instance (Null a) ⇒ Null (SepR i a) where +instance (Null a) ⇒ Null (SepR i a) where -- {-# INLINE null #-} null = SepRSingle null instance (Append a) ⇒ Append (SepR i a) where @@ -105,11 +105,11 @@ instance (Append a) ⇒ Append (SepR i a) where SepRSingle x₁ ⧺ SepRSingle x₂ = SepRSingle $ x₁ ⧺ x₂ SepRSingle x₁ ⧺ SepRMulti n x₂ i₂ xis₂ y₂ = SepRMulti n (x₁ ⧺ x₂) i₂ xis₂ y₂ SepRMulti n x₁ i₁ xis₁ y₁ ⧺ SepRSingle x₂ = SepRMulti n x₁ i₁ xis₁ (y₁ ⧺ x₂) - SepRMulti n₁ x₁ i₁ xis₁ y₁ ⧺ SepRMulti n₂ x₂ i₂ xis₂ y₂ = + SepRMulti n₁ x₁ i₁ xis₁ y₁ ⧺ SepRMulti n₂ x₂ i₂ xis₂ y₂ = SepRMulti (n₁ + n₂) x₁ i₁ (xis₁ ⧺ single ((y₁ ⧺ x₂) :* i₂) ⧺ xis₂) y₂ instance (Monoid a) ⇒ Monoid (SepR i a) -instance ToIter a (SepR a a) where +instance ToIter a (SepR a a) where -- {-# INLINE iter #-} iter (SepRSingle x) = single x iter (SepRMulti _ x i xis y) = concat @@ -118,7 +118,7 @@ instance ToIter a (SepR a a) where , single y ] -instance (Pretty a) ⇒ Pretty (SepR a a) where +instance (Pretty a) ⇒ Pretty (SepR a a) where -- {-# INLINE pretty #-} pretty = concat ∘ map pretty ∘ iter diff --git a/_scratch/OldVector.hs b/_scratch/OldVector.hs index 7cdb643c..af1b6593 100644 --- a/_scratch/OldVector.hs +++ b/_scratch/OldVector.hs @@ -64,7 +64,7 @@ idx𝕍 ∷ 𝕍 a → ℕ64 → a idx𝕍 (𝕍 a) ι = a BArr.! ι idx𝕍𝑂 ∷ 𝕍 a → ℕ64 → 𝑂 a -idx𝕍𝑂 a ι +idx𝕍𝑂 a ι | idxOK𝕍 a ι = Some $ idx𝕍 a ι | otherwise = None @@ -74,8 +74,8 @@ stream𝕍 xs = 𝑆 (𝕟64 0) $ \ ι → do return $ x :* succ ι size𝕍 ∷ 𝕍 a → ℕ64 -size𝕍 (𝕍 a) = - let (ιᴮ,ιᵀ) = BArr.bounds a +size𝕍 (𝕍 a) = + let (ιᴮ,ιᵀ) = BArr.bounds a in if ιᴮ > ιᵀ then zero else ιᵀ + one map𝕍 ∷ (a → b) → 𝕍 a → 𝕍 b @@ -102,13 +102,13 @@ emptyChunk n = repeat (nat n) (𝕟8 0) joinBytes ∷ (ℕ8,ℕ8,ℕ8,ℕ8,ℕ8,ℕ8,ℕ8,ℕ8) → ℕ64 joinBytes (b₁,b₂,b₃,b₄,b₅,b₆,b₇,b₈) = - HS.shiftL (HS.fromIntegral b₁ ∷ ℕ64) (HS.fromIntegral 0 ∷ HS.Int) - HS..|. HS.shiftL (HS.fromIntegral b₂ ∷ ℕ64) (HS.fromIntegral 8 ∷ HS.Int) - HS..|. HS.shiftL (HS.fromIntegral b₃ ∷ ℕ64) (HS.fromIntegral 16 ∷ HS.Int) + HS.shiftL (HS.fromIntegral b₁ ∷ ℕ64) (HS.fromIntegral 0 ∷ HS.Int) + HS..|. HS.shiftL (HS.fromIntegral b₂ ∷ ℕ64) (HS.fromIntegral 8 ∷ HS.Int) + HS..|. HS.shiftL (HS.fromIntegral b₃ ∷ ℕ64) (HS.fromIntegral 16 ∷ HS.Int) HS..|. HS.shiftL (HS.fromIntegral b₄ ∷ ℕ64) (HS.fromIntegral 24 ∷ HS.Int) - HS..|. HS.shiftL (HS.fromIntegral b₅ ∷ ℕ64) (HS.fromIntegral 32 ∷ HS.Int) - HS..|. HS.shiftL (HS.fromIntegral b₆ ∷ ℕ64) (HS.fromIntegral 40 ∷ HS.Int) - HS..|. HS.shiftL (HS.fromIntegral b₇ ∷ ℕ64) (HS.fromIntegral 48 ∷ HS.Int) + HS..|. HS.shiftL (HS.fromIntegral b₅ ∷ ℕ64) (HS.fromIntegral 32 ∷ HS.Int) + HS..|. HS.shiftL (HS.fromIntegral b₆ ∷ ℕ64) (HS.fromIntegral 40 ∷ HS.Int) + HS..|. HS.shiftL (HS.fromIntegral b₇ ∷ ℕ64) (HS.fromIntegral 48 ∷ HS.Int) HS..|. HS.shiftL (HS.fromIntegral b₈ ∷ ℕ64) (HS.fromIntegral 56 ∷ HS.Int) splitBytes ∷ ℕ64 → (ℕ8,ℕ8,ℕ8,ℕ8,ℕ8,ℕ8,ℕ8,ℕ8) @@ -147,7 +147,7 @@ instance Chunky 𝔹 where fromChunk g = do b ← g return $ case b ≡ 𝕟8 0 of - True → False + True → False False → True toChunk b = toChunk $ case b of False → 𝕟8 0 @@ -249,7 +249,7 @@ idx𝕌 ∷ ∀ a. (Chunky a) ⇒ 𝕌 a → ℕ64 → a idx𝕌 (𝕌 a) i = evalState (rawIdx𝕌 @ a P i) $ fromChunk $ chunkIOBytes a idx𝕌𝑂 ∷ (Chunky a) ⇒ 𝕌 a → ℕ64 → 𝑂 a -idx𝕌𝑂 a i +idx𝕌𝑂 a i | idxOK𝕌 a i = Some $ idx𝕌 a i | otherwise = None @@ -272,9 +272,9 @@ streamBytes𝕌 (𝕌 a) = -- examples -- corelib_vector_e1 ∷ 𝕌 (ℕ64 ∨ (ℕ64 ∧ ℕ64)) -corelib_vector_e1 = uvec $ mapOn (upTo 10) $ \ x → +corelib_vector_e1 = uvec $ mapOn (upTo 10) $ \ x → case even x of - True → Inl $ 𝕟64 x + True → Inl $ 𝕟64 x False → Inr $ 𝕟64 x :* 𝕟64 99 corelib_vector_e2 ∷ 𝕌 ℂ @@ -282,5 +282,3 @@ corelib_vector_e2 = uvec ['a','b','c','d','e','f'] corelib_vector_e3 ∷ 𝕌 𝔹 corelib_vector_e3 = uvec $ map (elimChoice even $ even ∘ fst) $ iter corelib_vector_e1 - - diff --git a/_scratch/OlderSep.hs b/_scratch/OlderSep.hs index b6b1735c..1e5e34cb 100644 --- a/_scratch/OlderSep.hs +++ b/_scratch/OlderSep.hs @@ -3,19 +3,19 @@ module UVMHS.Lib.Parser.Sep where import UVMHS.Core import UVMHS.Lib.Pretty --- data Sep i a = +-- data Sep i a = -- SepE a -- | SepS a i (𝐼 (a ∧ i)) a --- +-- -- sepI ∷ (Null a) ⇒ i → Sep i a -- sepI i = SepS null i null null --- +-- -- instance (Null a) ⇒ Null (Sep i a) where null = Sep null -- instance (Append a) ⇒ Append (Sep i a) where -- Sep x₁ ⧺ Sep x₂ = Sep $ x₁ ⧺ x₂ -- Sep x₁ ⧺ Sep x₂₁ i₂ xis₂ x₂₂ = Sep (x₁ ⧺ x₂₁) i₂ xis₂ x₂₂ -- Sep x₁₁ i₁ xis₁ x₁₂ ⧺ Sep x₂ = Sep x₁₁ i₁ xis₁ $ x₁₂ ⧺ x₂ --- Sep x₁₁ i₁ xis₁ x₁₂ ⧺ Sep x₂₁ i₂ xis₂ x₂₂ = +-- Sep x₁₁ i₁ xis₁ x₁₂ ⧺ Sep x₂₁ i₂ xis₂ x₂₂ = -- let xis' = xis₁ ⧺ single ((x₁₁ ⧺ x₂₁) :* i₂) ⧺ xis₂ -- in Sep x₁₁ i₁ xis' x₂₂ -- instance (Monoid a) ⇒ Monoid (Sep i a) @@ -30,12 +30,12 @@ instance (Append a) ⇒ Append (SepL i a) where None → SepL (x₁ ⧺ x₂) sxs₂ Some (sxs₁' :* (s₁ :* x₁')) → SepL x₁ (sxs₁' ⧺ single (s₁ :* (x₁' ⧺ x₂)) ⧺ sxs₂) instance (Monoid a) ⇒ Monoid (SepL i a) -instance ToStream a (SepL a a) where +instance ToStream a (SepL a a) where stream (SepL x₀ sxs₀) = concat [ single x₀ , concat $ mapOn sxs₀ $ \ (x :* y) → stream [x,y] ] -instance ToIter a (SepL a a) where +instance ToIter a (SepL a a) where iter (SepL x₀ sxs₀) = concat [ single x₀ , concat $ mapOn sxs₀ $ \ (x :* y) → iter [x,y] @@ -65,13 +65,13 @@ instance (Append a) ⇒ Append (SepR i a) where Some ((x₂' :* s₂) :* xss₂') → SepR (xss₁ ⧺ single ((x₁ ⧺ x₂') :* s₂) ⧺ xss₂') x₂ instance (Monoid a) ⇒ Monoid (SepR i a) -instance ToStream a (SepR a a) where - stream (SepR xss₀ x₀) = +instance ToStream a (SepR a a) where + stream (SepR xss₀ x₀) = mjoin $ flip (⧺) (single (single x₀)) - $ map (\ (x :* y) → stream [x,y]) + $ map (\ (x :* y) → stream [x,y]) $ stream xss₀ -instance ToIter a (SepR a a) where +instance ToIter a (SepR a a) where iter (SepR xss₀ x₀) = mjoin $ flip (⧺) (single (single x₀)) @@ -100,7 +100,7 @@ sepRL (SepR xss₀ x₀) = let (x₀' :* sxs₀') = loop xss₀ x₀ in SepL x loop ∷ 𝑄 (a ∧ i) → a → (a ∧ 𝑄 (i ∧ a)) loop xss x = case unsnoc𝑄 xss of None → (x :* null) - Some (xss' :* (x' :* s)) → + Some (xss' :* (x' :* s)) → let (y :* sys) = loop xss' x' in (y :* snoc𝑄 sys (s :* x)) diff --git a/_scratch/Substitution_attempted_local_global.hs b/_scratch/Substitution_attempted_local_global.hs index 2f4f8eda..5965d1b7 100644 --- a/_scratch/Substitution_attempted_local_global.hs +++ b/_scratch/Substitution_attempted_local_global.hs @@ -53,7 +53,7 @@ bvsubst (Subst ρ vs ι _gs) 𝓍 = if | 𝓍 < ρ → Inl 𝓍 -- 𝓍 ≥ ρ | 𝓍 - ρ < csize vs → vs ⋕! (𝓍 - ρ) - -- 𝓍 ≥ ρ + -- 𝓍 ≥ ρ -- 𝓍 - ρ < |vs| | otherwise → Inl $ natΩ64 $ intΩ64 𝓍 + ι @@ -104,11 +104,11 @@ bindSubst v = Subst -- bumpSubst[n](ρ,vs,ι) ≜ (ρ′,vs′,ι) -- where -- ρ′ = ρ+n --- vs′(n′) = +-- vs′(n′) = -- 𝓍+n if vs(n′) = 𝓍 -- (ρₑ+n,e) if vs(n′) = (ρₑ,e) -- shftSubst' ∷ ℕ64 → Subst a → Subst a --- shftSubst' n (Subst ρ vs ι gs) = +-- shftSubst' n (Subst ρ vs ι gs) = -- let ρ' = ρ + n -- vs' = mapOn vs $ \case -- Inl 𝓍 → Inl $ 𝓍 + n @@ -150,7 +150,7 @@ appendSubstOld 𝓈₂@(Subst ρ₂ vs₂ ι₂ gs₂) (Subst ρ₁ vs₁ ι₁ vsSize = logicalSize - ρ vsOffset₁ = ρ₁ - ρ ι = ι₁ + ι₂ - vs = vecF vsSize $ \ 𝓍 → + vs = vecF vsSize $ \ 𝓍 → if 𝓍 < vsOffset₁ then bvsubst 𝓈₂ $ ρ + 𝓍 else @@ -175,7 +175,7 @@ combineSubst sub 𝓈₂@(Subst ρ₂ vs₂ ι₂ gs₂) (Subst ρ₁ vs₁ ι vsSize = logicalSize - ρ vsOffset₁ = ρ₁ - ρ ι = ι₁ + ι₂ - vs ← exchange $ vecF vsSize $ \ 𝓍 → + vs ← exchange $ vecF vsSize $ \ 𝓍 → if 𝓍 < vsOffset₁ then return $ bvsubst 𝓈₂ $ ρ + 𝓍 else @@ -291,30 +291,30 @@ instance Rand ULCDExpR where prand = flip prandULCDExp zero 𝔱 "subst:intro" [| subst (intrSubst $ 𝕟64 2) [ulcd| λ → 2 |] |] [| [ulcd| λ → 4 |] |] 𝔱 "subst:intro" [| subst (intrSubst $ 𝕟64 2) [ulcd| λ → 0 2 |] |] [| [ulcd| λ → 0 4 |] |] -𝔱 "subst:bind" [| subst (bindSubst [ulcd| λ → 0 |]) [ulcd| λ → 0 |] |] +𝔱 "subst:bind" [| subst (bindSubst [ulcd| λ → 0 |]) [ulcd| λ → 0 |] |] [| [ulcd| λ → 0 |] |] -𝔱 "subst:bind" [| subst (bindSubst [ulcd| λ → 1 |]) [ulcd| λ → 0 |] |] +𝔱 "subst:bind" [| subst (bindSubst [ulcd| λ → 1 |]) [ulcd| λ → 0 |] |] [| [ulcd| λ → 0 |] |] -𝔱 "subst:bind" [| subst (bindSubst [ulcd| λ → 0 |]) [ulcd| λ → 1 |] |] +𝔱 "subst:bind" [| subst (bindSubst [ulcd| λ → 0 |]) [ulcd| λ → 1 |] |] [| [ulcd| λ → λ → 0 |] |] -𝔱 "subst:bind" [| subst (bindSubst [ulcd| λ → 1 |]) [ulcd| λ → 1 |] |] +𝔱 "subst:bind" [| subst (bindSubst [ulcd| λ → 1 |]) [ulcd| λ → 1 |] |] [| [ulcd| λ → λ → 2 |] |] -𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 0 |]) [ulcd| λ → 0 |] |] +𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 0 |]) [ulcd| λ → 0 |] |] [| [ulcd| λ → 0 |] |] -𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 1 |]) [ulcd| λ → 0 |] |] +𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 1 |]) [ulcd| λ → 0 |] |] [| [ulcd| λ → 0 |] |] -𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 0 |]) [ulcd| λ → 1 |] |] +𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 0 |]) [ulcd| λ → 1 |] |] [| [ulcd| λ → 1 |] |] -𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 1 |]) [ulcd| λ → 1 |] |] +𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 1 |]) [ulcd| λ → 1 |] |] [| [ulcd| λ → 1 |] |] -𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 2 |]) [ulcd| λ → 0 |] |] +𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 2 |]) [ulcd| λ → 0 |] |] [| [ulcd| λ → 0 |] |] -𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 2 |]) [ulcd| λ → 1 |] |] +𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 2 |]) [ulcd| λ → 1 |] |] [| [ulcd| λ → 1 |] |] -𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 1 |]) [ulcd| λ → 2 |] |] +𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 1 |]) [ulcd| λ → 2 |] |] [| [ulcd| λ → λ → 2 |] |] -𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 2 |]) [ulcd| λ → 2 |] |] +𝔱 "subst:bumpSubst" [| subst (bumpSubst one $ bindSubst [ulcd| λ → 2 |]) [ulcd| λ → 2 |] |] [| [ulcd| λ → λ → 3 |] |] -- append -- @@ -333,26 +333,26 @@ instance Rand ULCDExpR where prand = flip prandULCDExp zero 𝔱 "subst:⧺" [| subst (intrSubst one) [ulcd| λ → 1 |] |] [| [ulcd| λ → 2 |] |] 𝔱 "subst:⧺" [| subst (null ⧺ intrSubst one ⧺ null) [ulcd| λ → 1 |] |] [| [ulcd| λ → 2 |] |] -𝔱 "subst:⧺" +𝔱 "subst:⧺" [| subst (bindSubst [ulcd| λ → 0 |]) [ulcd| λ → 1 |] |] [| [ulcd| λ → λ → 0 |] |] -𝔱 "subst:⧺" +𝔱 "subst:⧺" [| subst (null ⧺ bindSubst [ulcd| λ → 0 |] ⧺ null) [ulcd| λ → 1 |] |] [| [ulcd| λ → λ → 0 |] |] 𝔱 "subst:⧺" [| subst (intrSubst $ 𝕟64 2) [ulcd| λ → 1 |] |] [| [ulcd| λ → 3 |] |] 𝔱 "subst:⧺" [| subst (intrSubst one ⧺ intrSubst one) [ulcd| λ → 1 |] |] [| [ulcd| λ → 3 |] |] -𝔱 "subst:⧺" - [| subst (bindSubst [ulcd| λ → 0 |]) [ulcd| λ → 1 |] |] +𝔱 "subst:⧺" + [| subst (bindSubst [ulcd| λ → 0 |]) [ulcd| λ → 1 |] |] [| [ulcd| λ → λ → 0 |] |] -𝔱 "subst:⧺" - [| subst (bumpSubst one (bindSubst [ulcd| λ → 0 |]) ⧺ intrSubst one) [ulcd| λ → 1 |] |] +𝔱 "subst:⧺" + [| subst (bumpSubst one (bindSubst [ulcd| λ → 0 |]) ⧺ intrSubst one) [ulcd| λ → 1 |] |] [| [ulcd| λ → λ → 0 |] |] -𝔱 "subst:⧺" - [| subst (intrSubst one ⧺ bindSubst [ulcd| 1 |]) [ulcd| 0 (λ → 2) |] |] +𝔱 "subst:⧺" + [| subst (intrSubst one ⧺ bindSubst [ulcd| 1 |]) [ulcd| 0 (λ → 2) |] |] [| [ulcd| 2 (λ → 2) |] |] -𝔱 "subst:⧺" - [| subst (bumpSubst one (weknSubst one (bindSubst [ulcd| 1 |])) ⧺ intrSubst one) [ulcd| 0 (λ → 2) |] |] +𝔱 "subst:⧺" + [| subst (bumpSubst one (weknSubst one (bindSubst [ulcd| 1 |])) ⧺ intrSubst one) [ulcd| 0 (λ → 2) |] |] [| [ulcd| 2 (λ → 2) |] |] 𝔱 "subst:⧺" @@ -388,7 +388,7 @@ instance Rand ULCDExpR where prand = flip prandULCDExp zero [| [ulcd| 0 |] |] 𝔱 "subst:glbl" - [| (Subst 1 (vec []) 1 (var "x" ↦ 0 :* [ulcd| 1 |])) + [| (Subst 1 (vec []) 1 (var "x" ↦ 0 :* [ulcd| 1 |])) ⧺ (Subst 1 (vec []) 1 (var "x" ↦ 1 :* [ulcd| 1 |])) |] @@ -396,7 +396,7 @@ instance Rand ULCDExpR where prand = flip prandULCDExp zero [| null |] 𝔱 "subst:glbl" - [| subst ((Subst 1 (vec []) 1 (var "x" ↦ 0 :* [ulcd| 1 |])) + [| subst ((Subst 1 (vec []) 1 (var "x" ↦ 0 :* [ulcd| 1 |])) ⧺ (Subst 1 (vec []) 1 (var "x" ↦ 1 :* [ulcd| 1 |]))) $ [ulcd| λ → x |] @@ -407,108 +407,107 @@ instance Rand ULCDExpR where prand = flip prandULCDExp zero -- fuzzing -- -- 𝔣 "zzz:subst:wf" (𝕟64 100) [| randSml @ (Subst ULCDExpR) |] [| wfSubst |] --- --- 𝔣 "zzz:subst:⧺:wf" (𝕟64 100) +-- +-- 𝔣 "zzz:subst:⧺:wf" (𝕟64 100) -- [| do 𝓈₁ ← randSml @ (Subst ULCDExpR) -- 𝓈₂ ← randSml @ (Subst ULCDExpR) -- return $ 𝓈₁ :* 𝓈₂ -- |] -- [| \ (𝓈₁ :* 𝓈₂) → wfSubst (𝓈₁ ⧺ 𝓈₂) |] --- --- 𝔣 "zzz:subst:refl:hom" (𝕟64 100) +-- +-- 𝔣 "zzz:subst:refl:hom" (𝕟64 100) -- [| do e ← randOne @ ULCDExpR -- return $ e -- |] --- [| \ e → +-- [| \ e → -- subst nullSubst e ≡ e -- |] --- +-- -- 𝔣 "zzz:subst:refl/wk:hom" (𝕟64 100) -- [| do n ← randSml @ ℕ64 -- e ← randSml @ ULCDExpR -- return $ n :* e -- |] --- [| \ (n :* e) → subst (bumpSubst n nullSubst) e ≡ e +-- [| \ (n :* e) → subst (bumpSubst n nullSubst) e ≡ e -- |] --- +-- -- 𝔣 "zzz:subst:bind" (𝕟64 100) -- [| do e₁ ← randSml @ ULCDExpR -- e₂ ← randSml @ ULCDExpR -- return $ e₁ :* e₂ -- |] --- [| \ (e₁ :* e₂) → --- subst (bindSubst e₁ ⧺ intrSubst one) e₂ --- ≡ +-- [| \ (e₁ :* e₂) → +-- subst (bindSubst e₁ ⧺ intrSubst one) e₂ +-- ≡ -- e₂ -- |] --- +-- -- 𝔣 "zzz:subst:commute" (𝕟64 100) -- [| do e₁ ← randSml @ ULCDExpR -- e₂ ← randSml @ ULCDExpR -- return $ e₁ :* e₂ -- |] --- [| \ (e₁ :* e₂) → +-- [| \ (e₁ :* e₂) → -- subst (intrSubst one ⧺ bindSubst e₁) e₂ --- ≡ +-- ≡ -- subst (bumpSubst one (weknSubst one $ bindSubst e₁) ⧺ intrSubst one) e₂ -- |] -𝔣 "zzz:subst:⧺:hom" (𝕟64 100) +𝔣 "zzz:subst:⧺:hom" (𝕟64 100) [| do 𝓈₁ ← randOne @ (Subst ULCDExpR) 𝓈₂ ← randOne @ (Subst ULCDExpR) e ← randOne @ ULCDExpR return $ 𝓈₁ :* 𝓈₂ :* e |] - [| \ (𝓈₁ :* 𝓈₂ :* e) → + [| \ (𝓈₁ :* 𝓈₂ :* e) → subst (𝓈₁ ⧺ 𝓈₂) e ≡ subst 𝓈₁ (subst 𝓈₂ e) |] --- 𝔣 "zzz:subst:⧺:lrefl" (𝕟64 100) +-- 𝔣 "zzz:subst:⧺:lrefl" (𝕟64 100) -- [| do 𝓈 ← randSml @ (Subst ULCDExpR) -- e ← randSml @ ULCDExpR -- return $ 𝓈 :* e -- |] --- [| \ (𝓈 :* e) → +-- [| \ (𝓈 :* e) → -- subst (nullSubst ⧺ 𝓈) e ≡ subst 𝓈 e -- |] --- --- 𝔣 "zzz:subst:⧺:rrefl" (𝕟64 100) +-- +-- 𝔣 "zzz:subst:⧺:rrefl" (𝕟64 100) -- [| do 𝓈 ← randSml @ (Subst ULCDExpR) -- e ← randSml @ ULCDExpR -- return $ 𝓈 :* e -- |] --- [| \ (𝓈 :* e) → +-- [| \ (𝓈 :* e) → -- subst (𝓈 ⧺ nullSubst) e ≡ subst 𝓈 e -- |] --- +-- -- 𝔣 "zzz:subst:⧺:lrefl/wk" (𝕟64 100) -- [| do n ← randSml @ ℕ64 -- 𝓈 ← randSml @ (Subst ULCDExpR) -- e ← randSml @ ULCDExpR -- return $ n :* 𝓈 :* e -- |] --- [| \ (n :* 𝓈 :* e) → subst (bumpSubst n nullSubst ⧺ 𝓈) e ≡ subst 𝓈 e +-- [| \ (n :* 𝓈 :* e) → subst (bumpSubst n nullSubst ⧺ 𝓈) e ≡ subst 𝓈 e -- |] --- +-- -- 𝔣 "zzz:subst:⧺:rrefl/wk" (𝕟64 100) -- [| do n ← randSml @ ℕ64 -- 𝓈 ← randSml @ (Subst ULCDExpR) -- e ← randSml @ ULCDExpR -- return $ n :* 𝓈 :* e -- |] --- [| \ (n :* 𝓈 :* e) → subst (𝓈 ⧺ bumpSubst n nullSubst) e ≡ subst 𝓈 e +-- [| \ (n :* 𝓈 :* e) → subst (𝓈 ⧺ bumpSubst n nullSubst) e ≡ subst 𝓈 e -- |] --- --- 𝔣 "zzz:subst:⧺:trans" (𝕟64 100) +-- +-- 𝔣 "zzz:subst:⧺:trans" (𝕟64 100) -- [| do 𝓈₁ ← randSml @ (Subst ULCDExpR) -- 𝓈₂ ← randSml @ (Subst ULCDExpR) -- 𝓈₃ ← randSml @ (Subst ULCDExpR) -- e ← randSml @ ULCDExpR -- return $ 𝓈₁ :* 𝓈₂ :* 𝓈₃ :* e -- |] --- [| \ (𝓈₁ :* 𝓈₂ :* 𝓈₃ :* e) → --- subst ((𝓈₁ ⧺ 𝓈₂) ⧺ 𝓈₃) e ≡ subst (𝓈₁ ⧺ (𝓈₂ ⧺ 𝓈₃)) e +-- [| \ (𝓈₁ :* 𝓈₂ :* 𝓈₃ :* e) → +-- subst ((𝓈₁ ⧺ 𝓈₂) ⧺ 𝓈₃) e ≡ subst (𝓈₁ ⧺ (𝓈₂ ⧺ 𝓈₃)) e -- |] buildTests - diff --git a/_scratch/Tr.hs b/_scratch/Tr.hs index 8d671cee..8b73569b 100644 --- a/_scratch/Tr.hs +++ b/_scratch/Tr.hs @@ -15,7 +15,7 @@ data TrI h o a where data ExTr o a where ExTr ∷ ∀ h o a. Tr h o a → ExTr o a -data ExTallTr h o a where +data ExTallTr h o a where EqTlTr ∷ ∀ h o a. Tr h o a → ExTallTr h o a SuccTr ∷ ∀ h o a. Tr h o a → Tr h o a → ExTallTr h o a @@ -89,7 +89,7 @@ searchTr s t c = case s $ sryTr t of R → NotFoundTr $ PositionTr Right t c C → searchTrI s (tr t) c N → error "search direction should never be N" - + searchTrI ∷ (o → Search) → TrI hᴵ o a → TrK hᴵ hᴼ o a → SearchTr hᴼ o a searchTrI _ (Tr0 x) c = FoundTr x c searchTrI s (Tr2 tˡ tʳ) c = case (s $ sryTr tˡ,s $ sryTr tʳ) of @@ -166,7 +166,7 @@ snocTr ∷ (Append o,Summary o a) ⇒ Tr h o a → a → ExTallTr h o a snocTr t x = snocTrK t x TopTr unconsTr ∷ (Append o) ⇒ Tr h o a → a ∧ ExShortTr h o a -unconsTr t = +unconsTr t = let x :* c = locFstTr t TopTr in x :* balHoleTr c @@ -259,4 +259,3 @@ streamTr t = 𝑆 (Some $ locFstTr𝑆 t TopTr𝑆) $ \case Some (x :* c) → Some (x :* nextTr𝑆 c) instance ToStream a (Tr h o a) where stream = streamTr - diff --git a/_scratch/VectorMultiDim.hs b/_scratch/VectorMultiDim.hs index fbe4784b..46e652cc 100644 --- a/_scratch/VectorMultiDim.hs +++ b/_scratch/VectorMultiDim.hs @@ -128,7 +128,7 @@ dimB𝕍 ∷ B𝕍 ns a → Sℕ32s ns dimB𝕍 (B𝕍 n _) = n indexB𝕍 ∷ 𝕀32s ns → B𝕍 ns a → a -indexB𝕍 i (B𝕍 _ xs) = xs Repa.! toRepa𝕀32s i +indexB𝕍 i (B𝕍 _ xs) = xs Repa.! toRepa𝕀32s i virtB𝕍 ∷ B𝕍 ns a → V𝕍 ns a virtB𝕍 (B𝕍 n xs) = V𝕍 n $ Repa.delay xs @@ -147,11 +147,11 @@ dimV𝕍 ∷ V𝕍 ns a → Sℕ32s ns dimV𝕍 (V𝕍 n _) = n indexV𝕍 ∷ 𝕀32s ns → V𝕍 ns a → a -indexV𝕍 i (V𝕍 _ xs) = xs Repa.! toRepa𝕀32s i +indexV𝕍 i (V𝕍 _ xs) = xs Repa.! toRepa𝕀32s i makeV𝕍 ∷ Sℕ32s ns → (𝕀32s ns → a) → V𝕍 ns a -makeV𝕍 n f = with (toShapeSℕ32s n) $ - V𝕍 n $ Repa.fromFunction (toRepaSℕ32s n) $ \ i → +makeV𝕍 n f = with (toShapeSℕ32s n) $ + V𝕍 n $ Repa.fromFunction (toRepaSℕ32s n) $ \ i → f (frRepa𝕀32s n i) concV𝕍 ∷ V𝕍 ns a → B𝕍 ns a @@ -168,7 +168,7 @@ zipWithV𝕍 ∷ (a → b → c) → V𝕍 ns a → V𝕍 ns b → V𝕍 ns c zipWithV𝕍 f xs ys = makeV𝕍 (dimV𝕍 xs) $ \ i → f (indexV𝕍 i xs) (indexV𝕍 i ys) transposeV𝕍 ∷ V𝕍 (n₁ : n₂ : ns) a → V𝕍 (n₂ : n₁ : ns) a -transposeV𝕍 xs = +transposeV𝕍 xs = let (n₁ :&& n₂ :&& ns) = dimV𝕍 xs in makeV𝕍 (n₂ :&& n₁ :&& ns) $ \ (i₂ :&& i₁ :&& is) → indexV𝕍 (i₁ :&& i₂ :&& is) xs @@ -186,7 +186,7 @@ productV𝕍 ∷ (Additive a,Times a) ⇒ V𝕍 [n₁,n₂] a → V𝕍 [n₂,n productV𝕍 xs ys = let (n₁ :&& _ :&& SNil) = dimV𝕍 xs (_ :&& n₃ :&& SNil) = dimV𝕍 ys - in + in makeV𝕍 (n₁ :&& n₃ :&& SNil) $ \ (i₁ :&& i₃ :&& SNil) → let v₁ = rowV𝕍 i₁ xs v₂ = colV𝕍 i₃ ys diff --git a/_scratch/WizPL.hs b/_scratch/WizPL.hs index 444fb0f9..5c25e6c3 100644 --- a/_scratch/WizPL.hs +++ b/_scratch/WizPL.hs @@ -9,7 +9,7 @@ import UVMHS type SType = Annotated FullContext SType_R data SType_R = Int_ST -- int - | Fun_ST SType SType -- + | Fun_ST SType SType -- deriving (Eq,Ord,Show) makePrettySum ''SType_R @@ -49,15 +49,15 @@ makePrettySum ''SCmd_R ----------- lexer ∷ Lexer CharClass ℂ TokenClassWSBasic ℕ64 TokenWSBasic -lexer = lexerWSBasic +lexer = lexerWSBasic -- punctuation - (list ["(",")",":","=","=>","->"]) + (list ["(",")",":","=","=>","->"]) -- keywords (list ["fun"]) -- primitives - (list ["int"]) + (list ["int"]) -- operations - (list ["+","-","*","<=","<","==","+","*","-","^","!"]) + (list ["+","-","*","<=","<","==","+","*","-","^","!"]) -- block (list []) @@ -114,7 +114,7 @@ pExp = fmixfixWithContext "exp" $ concat -- integer , fmixTerminal $ Int_SE ^$ cpIntegerWS -- binary ops - , concat $ mapOn binaryOps $ \ (s :* op :* level :* fy) → + , concat $ mapOn binaryOps $ \ (s :* op :* level :* fy) → let mk = case fy of NoF → fmixInfix LeftF → fmixInfixL @@ -161,4 +161,3 @@ testParser = parseMain "" $ concat $ inbetween "\n" , "f = fun x => fun y =>" , " x + y" ] - diff --git a/src/Examples/Lang/Arith.hs b/src/Examples/Lang/Arith.hs index cd376488..dc4bd947 100644 --- a/src/Examples/Lang/Arith.hs +++ b/src/Examples/Lang/Arith.hs @@ -6,8 +6,8 @@ lexer ∷ Lexer CharClass ℂ TokenClassBasic ℕ64 TokenBasic lexer = lexerBasic (list ["(",")"]) null null (list ["==","+","*","-","^","!"]) testTokenizerSuccess ∷ IO () -testTokenizerSuccess = - tokenizeIOMain lexer "" $ tokens "1 + 2 - 3 * 4 ^ 5 ! == 1 \n -- blah blah \n {- ml {{- ml --}-} -- blah\nb" +testTokenizerSuccess = + tokenizeIOMain lexer "" $ tokens "1 + 2 - 3 * 4 ^ 5 ! == 1 \n -- blah blah \n {- ml {{- ml --}-} -- blah\nb" data Lit = IntegerL ℤ @@ -45,7 +45,7 @@ cpAtom = cpNewContext "atom" $ tries , NameA ^$ cpShaped $ view nameTBasicL ] -cpExp ∷ CParser TokenBasic Exp +cpExp ∷ CParser TokenBasic Exp cpExp = fmixfixWithContext "exp" $ concat [ fmixTerminal $ do void $ cpToken $ SyntaxTBasic "(" @@ -70,4 +70,3 @@ testParserFailure1 = parseIOMain cpExp "" *$ tokenizeIO lexer "" $ tokens "((9 = testParserFailure2 ∷ IO () testParserFailure2 = parseIOMain cpExp "" *$ tokenizeIO lexer "" $ tokens "(((((- 1))) + 2 + 3 * 4 ^ 5 ^ ! == 0))" - diff --git a/src/Examples/Lang/ArithBlocks.hs b/src/Examples/Lang/ArithBlocks.hs index b3c2c820..2c72e293 100644 --- a/src/Examples/Lang/ArithBlocks.hs +++ b/src/Examples/Lang/ArithBlocks.hs @@ -6,7 +6,7 @@ lexer ∷ Lexer CharClass ℂ TokenClassWSBasic ℕ64 TokenWSBasic lexer = lexerWSBasic (list ["(",")"]) null null (list ["==","+","*","-","^","!"]) (list ["local"]) testTokenizerSuccess ∷ IO () -testTokenizerSuccess = +testTokenizerSuccess = tokenizeFIOMain lexer "" blockifyTokensWSBasic $ tokens $ concat $ inbetween "\n" [ "1 -- blah" , "2" @@ -67,7 +67,7 @@ cpBlock = cpNewContext "block" $ do void $ cpCloseWS return es -cpExp ∷ CParser TokenWSBasic Exp +cpExp ∷ CParser TokenWSBasic Exp cpExp = fmixfixWithContext "exp" $ concat [ fmixTerminal $ do void $ cpToken $ SyntaxTWSBasic "(" @@ -91,8 +91,8 @@ testParserSuccess ∷ IO () testParserSuccess = do parseIOMain cpExpList "" *$ tokenizeFIO lexer "" blockifyTokensWSBasic - $ tokens - $ concat + $ tokens + $ concat $ inbetween "\n" [ "(- 1) + 2" , "local 2 + 3" @@ -101,11 +101,11 @@ testParserSuccess = do ] testParserFailure ∷ IO () -testParserFailure = +testParserFailure = parseIOMain cpExpList "" *$ tokenizeFIO lexer "" blockifyTokensWSBasic - $ tokens - $ concat + $ tokens + $ concat $ inbetween "\n" [ "(- 1) + 2" , "local 2 + 3 + 4" diff --git a/src/Examples/Lang/SExp.hs b/src/Examples/Lang/SExp.hs index d178e33d..f7fc4d0c 100644 --- a/src/Examples/Lang/SExp.hs +++ b/src/Examples/Lang/SExp.hs @@ -6,7 +6,7 @@ lexer ∷ Lexer CharClass ℂ TokenClassBasic ℕ64 TokenBasic lexer = lexerBasic (list ["(",")"]) (list ["KEY"]) (list ["PRIM"]) (list ["+"]) testSExpTokenizerSuccess ∷ IO () -testSExpTokenizerSuccess = +testSExpTokenizerSuccess = tokenizeIOMain lexer "" $ tokens "((-1-2-1.42(\"astringwith\\\\stuff\\n\" ( " testSExpTokenizerFailure1 ∷ IO () diff --git a/src/UVMHS/Core/Chunky.hs b/src/UVMHS/Core/Chunky.hs index 116c2e48..77bdc6e1 100644 --- a/src/UVMHS/Core/Chunky.hs +++ b/src/UVMHS/Core/Chunky.hs @@ -42,13 +42,13 @@ emptyChunk n = replicate (nat n) (𝕟8 0) joinBytes ∷ (ℕ8,ℕ8,ℕ8,ℕ8,ℕ8,ℕ8,ℕ8,ℕ8) → ℕ64 joinBytes (b₁,b₂,b₃,b₄,b₅,b₆,b₇,b₈) = - nat64 b₁ ⋘ 𝕟64 0 - ⟇ nat64 b₂ ⋘ 𝕟64 8 - ⟇ nat64 b₃ ⋘ 𝕟64 16 + nat64 b₁ ⋘ 𝕟64 0 + ⟇ nat64 b₂ ⋘ 𝕟64 8 + ⟇ nat64 b₃ ⋘ 𝕟64 16 ⟇ nat64 b₄ ⋘ 𝕟64 24 - ⟇ nat64 b₅ ⋘ 𝕟64 32 - ⟇ nat64 b₆ ⋘ 𝕟64 40 - ⟇ nat64 b₇ ⋘ 𝕟64 48 + ⟇ nat64 b₅ ⋘ 𝕟64 32 + ⟇ nat64 b₆ ⋘ 𝕟64 40 + ⟇ nat64 b₇ ⋘ 𝕟64 48 ⟇ nat64 b₈ ⋘ 𝕟64 56 splitBytes ∷ ℕ64 → (ℕ8,ℕ8,ℕ8,ℕ8,ℕ8,ℕ8,ℕ8,ℕ8) @@ -88,7 +88,7 @@ instance Chunky 𝔹 where fromChunk g = do b ← g return $ case b ≡ 𝕟8 0 of - True → False + True → False False → True toChunk b = toChunk $ case b of False → 𝕟8 0 @@ -101,10 +101,10 @@ instance Chunky ℂ where return $ HS.chr $ tohs $ frBitsℤ64 $ joinBytes (b₁,b₂,b₃,b₄,𝕟8 0,𝕟8 0,𝕟8 0,𝕟8 0) toChunk c = 𝐼 HS.$ \ (f ∷ ℕ8 → b → (b → b) → b) i 𝓀 → let (b₁,b₂,b₃,b₄,_,_,_,_) = splitBytes $ toBitsℤ64 $ frhs $ HS.ord c - in + in f b₁ i $ \ i' → - f b₂ i' $ \ i'' → - f b₃ i'' $ \ i''' → + f b₂ i' $ \ i'' → + f b₃ i'' $ \ i''' → f b₄ i''' 𝓀 instance Chunky ℕ64 where @@ -115,7 +115,7 @@ instance Chunky ℕ64 where return $ joinBytes (b₁,b₂,b₃,b₄,b₅,b₆,b₇,b₈) toChunk n = 𝐼 HS.$ \ (f ∷ ℕ8 → b → (b → b) → b) i 𝓀 → let (b₁,b₂,b₃,b₄,b₅,b₆,b₇,b₈) = splitBytes n - in + in f b₁ i $ \ i' → f b₂ i' $ \ i'' → f b₃ i'' $ \ i''' → diff --git a/src/UVMHS/Core/Classes/Comonad.hs b/src/UVMHS/Core/Classes/Comonad.hs index d8461b98..8c5dfcae 100644 --- a/src/UVMHS/Core/Classes/Comonad.hs +++ b/src/UVMHS/Core/Classes/Comonad.hs @@ -3,7 +3,7 @@ module UVMHS.Core.Classes.Comonad where import UVMHS.Core.Init import UVMHS.Core.Classes.Functors -infixr 1 =≫ +infixr 1 =≫ class Extract (w ∷ ★ → ★) where extract ∷ w a → a class Cobind (w ∷ ★ → ★) where (=≫) ∷ w a → (w a → b) → w b @@ -35,4 +35,3 @@ submerge aMW = map (siphon aMW) (extract aMW) wmap ∷ (Comonad w) ⇒ (a → b) → w a → w b wmap = wextend ∘ kextract - diff --git a/src/UVMHS/Core/Classes/Functors.hs b/src/UVMHS/Core/Classes/Functors.hs index ceb6c421..f59f269a 100644 --- a/src/UVMHS/Core/Classes/Functors.hs +++ b/src/UVMHS/Core/Classes/Functors.hs @@ -17,10 +17,10 @@ newtype NoCostID (a ∷ ★) = NoCostID a instance Functor NoCostID where map ∷ ∀ a b. (a → b) → NoCostID a → NoCostID b map = coerce @((a → b) → a → b) id -instance Return NoCostID where +instance Return NoCostID where return ∷ ∀ a. a → NoCostID a return = coerce @a -instance Bind NoCostID where +instance Bind NoCostID where (≫=) ∷ ∀ a b. NoCostID a → (a → NoCostID b) → NoCostID b (≫=) = coerce @(a → (a → b) → b) appto instance Monad NoCostID @@ -29,10 +29,10 @@ instance Monad NoCostID -- FunctorM -- -------------- -class FunctorM (t ∷ ★ → ★) where +class FunctorM (t ∷ ★ → ★) where mapM ∷ ∀ m a b. (Monad m) ⇒ (a → m b) → t a → m (t b) -- DEFAULTS -- - default mapM ∷ (OFunctorM t,Monad m) ⇒ (a → m b) → t a → m (t b) + default mapM ∷ (OFunctorM t,Monad m) ⇒ (a → m b) → t a → m (t b) mapM f = omapM $ map Some ∘ f class OFunctorM (t ∷ ★ → ★) where omapM ∷ ∀ m a b. (Monad m) ⇒ (a → m (𝑂 b)) → t a → m (t b) @@ -52,26 +52,26 @@ class OKFunctorM (k ∷ ★) (t ∷ ★ → ★) | t → k where -- BiFunctorM -- ---------------- -class BiFunctorM (t ∷ ★ → ★) where +class BiFunctorM (t ∷ ★ → ★) where bimapM ∷ ∀ m a b c. (Monad m) ⇒ (a → m c) → (b → m c) → (a → b → m c) → t a → t b → m (t c) -- DEFAULTS -- default bimapM ∷ (OBiFunctorM t,Monad m) ⇒ (a → m c) → (b → m c) → (a → b → m c) → t a → t b → m (t c) bimapM f₁ f₂ f₃ = obimapM (map Some ∘ f₁) (map Some ∘ f₂) $ map Some ∘∘ f₃ -class OBiFunctorM (t ∷ ★ → ★) where +class OBiFunctorM (t ∷ ★ → ★) where obimapM ∷ ∀ m a b c. (Monad m) ⇒ (a → m (𝑂 c)) → (b → m (𝑂 c)) → (a → b → m (𝑂 c)) → t a → t b → m (t c) -class KBiFunctorM (k ∷ ★) (t ∷ ★ → ★) | t → k where +class KBiFunctorM (k ∷ ★) (t ∷ ★ → ★) | t → k where kbimapM ∷ ∀ m a b c. (Monad m) ⇒ (k → a → m c) → (k → b → m c) → (k → a → b → m c) → t a → t b → m (t c) -- DEFAULTS -- default kbimapM ∷ (OKBiFunctorM k t,Monad m) ⇒ (k → a → m c) → (k → b → m c) → (k → a → b → m c) → t a → t b → m (t c) kbimapM f₁ f₂ f₃ = okbimapM (map Some ∘∘ f₁) (map Some ∘∘ f₂) $ map Some ∘∘∘ f₃ -class OKBiFunctorM (k ∷ ★) (t ∷ ★ → ★) | t → k where +class OKBiFunctorM (k ∷ ★) (t ∷ ★ → ★) | t → k where okbimapM ∷ ∀ m a b c. (Monad m) ⇒ (k → a → m (𝑂 c)) → (k → b → m (𝑂 c)) → (k → a → b → m (𝑂 c)) → t a → t b → m (t c) ------------- -- Functor -- ------------- -class Functor (t ∷ ★ → ★) where +class Functor (t ∷ ★ → ★) where map ∷ (a → b) → t a → t b -- DEFAULTS -- default map ∷ ∀ a b. (FunctorM t) ⇒ (a → b) → t a → t b @@ -81,7 +81,7 @@ class OFunctor (t ∷ ★ → ★) where -- DEFAULTS -- default omap ∷ ∀ a b. (OFunctorM t) ⇒ (a → 𝑂 b) → t a → t b omap f = coerce $ omapM @t @NoCostID @a @b $ coerce f -class KFunctor (k ∷ ★) (t ∷ ★ → ★) | t → k where +class KFunctor (k ∷ ★) (t ∷ ★ → ★) | t → k where kmap ∷ (k → a → b) → t a → t b kmapAt ∷ k → (a → a) → t a → t a -- DEFAULTS -- @@ -89,7 +89,7 @@ class KFunctor (k ∷ ★) (t ∷ ★ → ★) | t → k where kmap f = coerce $ kmapM @k @t @NoCostID @a @b $ coerce f default kmapAt ∷ ∀ a. (KFunctorM k t) ⇒ k → (a → a) → t a → t a kmapAt k f = coerce $ kmapAtM @k @t @NoCostID @a k $ coerce f -class OKFunctor (k ∷ ★) (t ∷ ★ → ★) | t → k where +class OKFunctor (k ∷ ★) (t ∷ ★ → ★) | t → k where okmap ∷ (k → a → 𝑂 b) → t a → t b okmapAt ∷ k → (𝑂 a → 𝑂 a) → t a → t a -- DEFAULTS -- @@ -102,22 +102,22 @@ class OKFunctor (k ∷ ★) (t ∷ ★ → ★) | t → k where -- BiFunctor -- --------------- -class BiFunctor (t ∷ ★ → ★) where +class BiFunctor (t ∷ ★ → ★) where bimap ∷ (a → c) → (b → c) → (a → b → c) → t a → t b → t c -- DEFAULTS -- default bimap ∷ ∀ a b c. (BiFunctorM t) ⇒ (a → c) → (b → c) → (a → b → c) → t a → t b → t c bimap f₁ f₂ f₃ = coerce $ bimapM @t @NoCostID @a @b @c (coerce f₁) (coerce f₂) $ coerce f₃ -class OBiFunctor (t ∷ ★ → ★) where +class OBiFunctor (t ∷ ★ → ★) where obimap ∷ (a → 𝑂 c) → (b → 𝑂 c) → (a → b → 𝑂 c) → t a → t b → t c -- DEFAULTS -- default obimap ∷ ∀ a b c. (OBiFunctorM t) ⇒ (a → 𝑂 c) → (b → 𝑂 c) → (a → b → 𝑂 c) → t a → t b → t c obimap f₁ f₂ f₃ = coerce $ obimapM @t @NoCostID @a @b @c (coerce f₁) (coerce f₂) $ coerce f₃ -class KBiFunctor (k ∷ ★) (t ∷ ★ → ★) where +class KBiFunctor (k ∷ ★) (t ∷ ★ → ★) where kbimap ∷ (k → a → c) → (k → b → c) → (k → a → b → c) → t a → t b → t c -- DEFAULTS -- default kbimap ∷ ∀ a b c. (KBiFunctorM k t) ⇒ (k → a → c) → (k → b → c) → (k → a → b → c) → t a → t b → t c kbimap f₁ f₂ f₃ = coerce $ kbimapM @k @t @NoCostID @a @b @c (coerce f₁) (coerce f₂) $ coerce f₃ -class OKBiFunctor (k ∷ ★) (t ∷ ★ → ★) where +class OKBiFunctor (k ∷ ★) (t ∷ ★ → ★) where okbimap ∷ (k → a → 𝑂 c) → (k → b → 𝑂 c) → (k → a → b → 𝑂 c) → t a → t b → t c -- DEFAULTS -- default okbimap ∷ ∀ a b c. (OKBiFunctorM k t) ⇒ (k → a → 𝑂 c) → (k → b → 𝑂 c) → (k → a → b → 𝑂 c) → t a → t b → t c @@ -160,7 +160,7 @@ kbimapMOn = \ xM yM f₁ f₂ f₃ → kbimapM f₁ f₂ f₃ xM yM okbimapMOn ∷ (OKBiFunctorM k t,Monad m) ⇒ t a → t b → (k → a → m (𝑂 c)) → (k → b → m (𝑂 c)) → (k → a → b → m (𝑂 c)) → m (t c) okbimapMOn = \ xM yM f₁ f₂ f₃ → okbimapM f₁ f₂ f₃ xM yM -mapOn ∷ (Functor t) ⇒ t a → (a → b) → t b +mapOn ∷ (Functor t) ⇒ t a → (a → b) → t b mapOn = flip map mapp ∷ (Functor t,Functor u) ⇒ (a → b) → t (u a) → t (u b) @@ -175,13 +175,13 @@ mappp = mapp ∘ map mapppOn ∷ (Functor t,Functor u,Functor v) ⇒ t (u (v a)) → (a → b) → t (u (v b)) mapppOn = flip mappp -(^$) ∷ (Functor t) ⇒ (a → b) → t a → t b +(^$) ∷ (Functor t) ⇒ (a → b) → t a → t b (^$) = map (^^$) ∷ (Functor t,Functor u) ⇒ (a → b) → t (u a) → t (u b) (^^$) = mapp -(^∘) ∷ (Functor t) ⇒ (b → c) → (a → t b) → a → t c +(^∘) ∷ (Functor t) ⇒ (b → c) → (a → t b) → a → t c (^∘) = \ g f → map g ∘ f (^^∘) ∷ (Functor t,Functor u) ⇒ (b → c) → (a → t (u b)) → a → t (u c) diff --git a/src/UVMHS/Core/Classes/Lattice.hs b/src/UVMHS/Core/Classes/Lattice.hs index c84e4645..3373ab14 100644 --- a/src/UVMHS/Core/Classes/Lattice.hs +++ b/src/UVMHS/Core/Classes/Lattice.hs @@ -18,7 +18,7 @@ class (Top a,Meet a) ⇒ MeetLattice a class (JoinLattice a,MeetLattice a) ⇒ Lattice a class Dual a where dual ∷ a → a -class Difference a where (⊟) ∷ a → a → a +class Difference a where (⊟) ∷ a → a → a data PartialOrdering = PLT | PEQ | PGT | PUN diff --git a/src/UVMHS/Core/Classes/Morphism.hs b/src/UVMHS/Core/Classes/Morphism.hs index 09710dd5..9c62d823 100644 --- a/src/UVMHS/Core/Classes/Morphism.hs +++ b/src/UVMHS/Core/Classes/Morphism.hs @@ -11,12 +11,12 @@ type (t ∷ (★ → ★) → ★ → ★) →⁼ (u ∷ (★ → ★) → ★ class a ⇄ b | a → b where isoto ∷ a → b isofr ∷ b → a -data Iso a b = Iso +data Iso a b = Iso { ito ∷ a → b , ifr ∷ b → a } -toiso ∷ (a ⇄ b) ⇒ Iso a b +toiso ∷ (a ⇄ b) ⇒ Iso a b toiso = Iso isoto isofr friso ∷ (a ⇄ b) ⇒ Iso b a @@ -25,7 +25,7 @@ friso = Iso isofr isoto class t ⇄⁻ u | t → u where isoto2 ∷ t →⁻ u isofr2 ∷ u →⁻ t -data Iso2 t u = Iso2 +data Iso2 t u = Iso2 { ito2 ∷ t →⁻ u , ifr2 ∷ u →⁻ t } @@ -55,30 +55,30 @@ class Transitive t where (⊚) ∷ t b c → t a b → t a c class (Reflexive t,Transitive t) ⇒ Category t class Symmetric t where {sym ∷ t a b → t b a} -instance Reflexive (→) where +instance Reflexive (→) where refl = id -instance Transitive (→) where +instance Transitive (→) where (⊚) = (∘) instance Category (→) -instance Reflexive Iso where +instance Reflexive Iso where refl = Iso id id instance Transitive Iso where Iso gto gfrom ⊚ Iso fto ffrom = Iso (gto ∘ fto) (ffrom ∘ gfrom) -instance Symmetric Iso where +instance Symmetric Iso where sym (Iso to from) = Iso from to instance Category Iso -instance Reflexive Iso2 where +instance Reflexive Iso2 where refl = Iso2 id id -instance Transitive Iso2 where +instance Transitive Iso2 where Iso2 gto gfrom ⊚ Iso2 fto ffrom = Iso2 (gto ∘ fto) (ffrom ∘ gfrom) -instance Symmetric Iso2 where +instance Symmetric Iso2 where sym (Iso2 to from) = Iso2 from to instance Category Iso2 -instance Reflexive Iso3 where +instance Reflexive Iso3 where refl = Iso3 id id -instance Transitive Iso3 where +instance Transitive Iso3 where Iso3 gto gfrom ⊚ Iso3 fto ffrom = Iso3 (gto ∘ fto) (ffrom ∘ gfrom) -instance Symmetric Iso3 where +instance Symmetric Iso3 where sym (Iso3 to from) = Iso3 from to instance Category Iso3 diff --git a/src/UVMHS/Core/Classes/Order.hs b/src/UVMHS/Core/Classes/Order.hs index 99362591..d197d55d 100644 --- a/src/UVMHS/Core/Classes/Order.hs +++ b/src/UVMHS/Core/Classes/Order.hs @@ -28,21 +28,21 @@ x ≥ y = case x ⋚ y of {LT → False;EQ → True;GT → True} (>) = (HS.>) (⩏) ∷ (Ord a) ⇒ a → a → a -x ⩏ y +x ⩏ y | x ≤ y = y | otherwise = x (⩎) ∷ (Ord a) ⇒ a → a → a -x ⩎ y +x ⩎ y | x ≤ y = x | otherwise = y minBy ∷ (Ord b) ⇒ (a → b) → a → a → a -minBy f x y +minBy f x y | f x ≤ f y = x | otherwise = y maxBy ∷ (Ord b) ⇒ (a → b) → a → a → a -maxBy f x y +maxBy f x y | f x ≥ f y = x | otherwise = y diff --git a/src/UVMHS/Core/Data/Arithmetic.hs b/src/UVMHS/Core/Data/Arithmetic.hs index 53b56f9c..7d1a116b 100644 --- a/src/UVMHS/Core/Data/Arithmetic.hs +++ b/src/UVMHS/Core/Data/Arithmetic.hs @@ -66,38 +66,38 @@ instance JoinLattice ℕ instance Monoid ℕ instance ToNat ℕ where nat = id -instance ToNatO64 ℕ where - natO64 n +instance ToNatO64 ℕ where + natO64 n | n > HS.fromIntegral (HS.maxBound @ℕ64) = None | otherwise = Some $ HS.fromIntegral n -instance ToNatO32 ℕ where - natO32 n +instance ToNatO32 ℕ where + natO32 n | n > HS.fromIntegral (HS.maxBound @ℕ32) = None | otherwise = Some $ HS.fromIntegral n -instance ToNatO16 ℕ where - natO16 n +instance ToNatO16 ℕ where + natO16 n | n > HS.fromIntegral (HS.maxBound @ℕ16) = None | otherwise = Some $ HS.fromIntegral n -instance ToNatO8 ℕ where - natO8 n +instance ToNatO8 ℕ where + natO8 n | n > HS.fromIntegral (HS.maxBound @ℕ8) = None | otherwise = Some $ HS.fromIntegral n instance ToInt ℕ where int = HS.fromIntegral -instance ToIntO64 ℕ where - intO64 n +instance ToIntO64 ℕ where + intO64 n | n > HS.fromIntegral (HS.maxBound @ℤ64) = None | otherwise = Some $ HS.fromIntegral n -instance ToIntO32 ℕ where - intO32 n +instance ToIntO32 ℕ where + intO32 n | n > HS.fromIntegral (HS.maxBound @ℤ32) = None | otherwise = Some $ HS.fromIntegral n -instance ToIntO16 ℕ where - intO16 n +instance ToIntO16 ℕ where + intO16 n | n > HS.fromIntegral (HS.maxBound @ℤ16) = None | otherwise = Some $ HS.fromIntegral n -instance ToIntO8 ℕ where - intO8 n +instance ToIntO8 ℕ where + intO8 n | n > HS.fromIntegral (HS.maxBound @ℤ8) = None | otherwise = Some $ HS.fromIntegral n @@ -134,34 +134,34 @@ instance Monoid ℕ64 instance ToNat ℕ64 where nat = HS.fromIntegral instance ToNat64 ℕ64 where nat64 = id -instance ToNatO32 ℕ64 where - natO32 n +instance ToNatO32 ℕ64 where + natO32 n | n > HS.fromIntegral (HS.maxBound @ℕ32) = None | otherwise = Some $ HS.fromIntegral n -instance ToNatO16 ℕ64 where - natO16 n +instance ToNatO16 ℕ64 where + natO16 n | n > HS.fromIntegral (HS.maxBound @ℕ16) = None | otherwise = Some $ HS.fromIntegral n -instance ToNatO8 ℕ64 where - natO8 n +instance ToNatO8 ℕ64 where + natO8 n | n > HS.fromIntegral (HS.maxBound @ℕ8) = None | otherwise = Some $ HS.fromIntegral n instance ToInt ℕ64 where int = HS.fromIntegral -instance ToIntO64 ℕ64 where - intO64 n +instance ToIntO64 ℕ64 where + intO64 n | n > HS.fromIntegral (HS.maxBound @ℤ64) = None | otherwise = Some $ HS.fromIntegral n -instance ToIntO32 ℕ64 where - intO32 n +instance ToIntO32 ℕ64 where + intO32 n | n > HS.fromIntegral (HS.maxBound @ℤ32) = None | otherwise = Some $ HS.fromIntegral n -instance ToIntO16 ℕ64 where - intO16 n +instance ToIntO16 ℕ64 where + intO16 n | n > HS.fromIntegral (HS.maxBound @ℤ16) = None | otherwise = Some $ HS.fromIntegral n -instance ToIntO8 ℕ64 where - intO8 n +instance ToIntO8 ℕ64 where + intO8 n | n > HS.fromIntegral (HS.maxBound @ℤ8) = None | otherwise = Some $ HS.fromIntegral n @@ -199,27 +199,27 @@ instance Monoid ℕ32 instance ToNat ℕ32 where nat = HS.fromIntegral instance ToNat64 ℕ32 where nat64 = HS.fromIntegral instance ToNat32 ℕ32 where nat32 = id -instance ToNatO16 ℕ32 where - natO16 n +instance ToNatO16 ℕ32 where + natO16 n | n > HS.fromIntegral (HS.maxBound @ℕ16) = None | otherwise = Some $ HS.fromIntegral n -instance ToNatO8 ℕ32 where - natO8 n +instance ToNatO8 ℕ32 where + natO8 n | n > HS.fromIntegral (HS.maxBound @ℕ8) = None | otherwise = Some $ HS.fromIntegral n instance ToInt ℕ32 where int = HS.fromIntegral instance ToInt64 ℕ32 where int64 = HS.fromIntegral -instance ToIntO32 ℕ32 where - intO32 n +instance ToIntO32 ℕ32 where + intO32 n | n > HS.fromIntegral (HS.maxBound @ℤ32) = None | otherwise = Some $ HS.fromIntegral n -instance ToIntO16 ℕ32 where - intO16 n +instance ToIntO16 ℕ32 where + intO16 n | n > HS.fromIntegral (HS.maxBound @ℤ16) = None | otherwise = Some $ HS.fromIntegral n -instance ToIntO8 ℕ32 where - intO8 n +instance ToIntO8 ℕ32 where + intO8 n | n > HS.fromIntegral (HS.maxBound @ℤ8) = None | otherwise = Some $ HS.fromIntegral n @@ -258,20 +258,20 @@ instance ToNat ℕ16 where nat = HS.fromIntegral instance ToNat64 ℕ16 where nat64 = HS.fromIntegral instance ToNat32 ℕ16 where nat32 = HS.fromIntegral instance ToNat16 ℕ16 where nat16 = id -instance ToNatO8 ℕ16 where - natO8 n +instance ToNatO8 ℕ16 where + natO8 n | n > HS.fromIntegral (HS.maxBound @ℕ8) = None | otherwise = Some $ HS.fromIntegral n instance ToInt ℕ16 where int = HS.fromIntegral instance ToInt64 ℕ16 where int64 = HS.fromIntegral instance ToInt32 ℕ16 where int32 = HS.fromIntegral -instance ToIntO16 ℕ16 where - intO16 n +instance ToIntO16 ℕ16 where + intO16 n | n > HS.fromIntegral (HS.maxBound @ℤ16) = None | otherwise = Some $ HS.fromIntegral n -instance ToIntO8 ℕ16 where - intO8 n +instance ToIntO8 ℕ16 where + intO8 n | n > HS.fromIntegral (HS.maxBound @ℤ8) = None | otherwise = Some $ HS.fromIntegral n @@ -316,8 +316,8 @@ instance ToInt ℕ8 where int = HS.fromIntegral instance ToInt64 ℕ8 where int64 = HS.fromIntegral instance ToInt32 ℕ8 where int32 = HS.fromIntegral instance ToInt16 ℕ8 where int16 = HS.fromIntegral -instance ToIntO8 ℕ8 where - intO8 n +instance ToIntO8 ℕ8 where + intO8 n | n > HS.fromIntegral (HS.maxBound @ℤ8) = None | otherwise = Some $ HS.fromIntegral n @@ -347,55 +347,55 @@ instance Additive ℤ instance Multiplicative ℤ instance Monoid ℤ -instance ToNatO ℤ where - natO i +instance ToNatO ℤ where + natO i | i < 𝕫 0 = None | otherwise = Some $ HS.fromIntegral i -instance ToNatO64 ℤ where - natO64 i +instance ToNatO64 ℤ where + natO64 i | i < 𝕫 0 = None | i > HS.fromIntegral (HS.maxBound @ℕ64) = None | otherwise = Some $ HS.fromIntegral i -instance ToNatO32 ℤ where - natO32 i +instance ToNatO32 ℤ where + natO32 i | i < 𝕫 0 = None | i > HS.fromIntegral (HS.maxBound @ℕ32) = None | otherwise = Some $ HS.fromIntegral i -instance ToNatO16 ℤ where - natO16 i +instance ToNatO16 ℤ where + natO16 i | i < 𝕫 0 = None | i > HS.fromIntegral (HS.maxBound @ℕ16) = None | otherwise = Some $ HS.fromIntegral i -instance ToNatO8 ℤ where - natO8 i +instance ToNatO8 ℤ where + natO8 i | i < 𝕫 0 = None | i > HS.fromIntegral (HS.maxBound @ℕ8) = None | otherwise = Some $ HS.fromIntegral i instance ToInt ℤ where int = id -instance ToIntO64 ℤ where - intO64 i +instance ToIntO64 ℤ where + intO64 i | i < HS.fromIntegral (HS.minBound @ℤ64) = None | i > HS.fromIntegral (HS.maxBound @ℤ64) = None | otherwise = Some $ HS.fromIntegral i -instance ToIntO32 ℤ where - intO32 i +instance ToIntO32 ℤ where + intO32 i | i < HS.fromIntegral (HS.minBound @ℤ32) = None | i > HS.fromIntegral (HS.maxBound @ℤ32) = None | otherwise = Some $ HS.fromIntegral i -instance ToIntO16 ℤ where - intO16 i +instance ToIntO16 ℤ where + intO16 i | i < HS.fromIntegral (HS.minBound @ℤ16) = None | i > HS.fromIntegral (HS.maxBound @ℤ16) = None | otherwise = Some $ HS.fromIntegral i -instance ToIntO8 ℤ where - intO8 i +instance ToIntO8 ℤ where + intO8 i | i < HS.fromIntegral (HS.minBound @ℤ8) = None | i > HS.fromIntegral (HS.maxBound @ℤ8) = None | otherwise = Some $ HS.fromIntegral i instance ToRational ℤ where rat = HS.fromIntegral -instance ToRationalᴾO ℤ where +instance ToRationalᴾO ℤ where ratᴾO i | i < 𝕫 0 = None | otherwise = Some $ HS.fromIntegral i @@ -435,50 +435,50 @@ instance JoinLattice ℤ64 instance MeetLattice ℤ64 instance Monoid ℤ64 -instance ToNatO ℤ64 where +instance ToNatO ℤ64 where natO i | i < 𝕫64 0 = None | otherwise = Some $ HS.fromIntegral i -instance ToNatO64 ℤ64 where +instance ToNatO64 ℤ64 where natO64 i | i < 𝕫64 0 = None | otherwise = Some $ HS.fromIntegral i -instance ToNatO32 ℤ64 where - natO32 i +instance ToNatO32 ℤ64 where + natO32 i | i < 𝕫64 0 = None | i > HS.fromIntegral (HS.maxBound @ℕ32) = None | otherwise = Some $ HS.fromIntegral i -instance ToNatO16 ℤ64 where - natO16 i +instance ToNatO16 ℤ64 where + natO16 i | i < 𝕫64 0 = None | i > HS.fromIntegral (HS.maxBound @ℕ16) = None | otherwise = Some $ HS.fromIntegral i -instance ToNatO8 ℤ64 where - natO8 i +instance ToNatO8 ℤ64 where + natO8 i | i < 𝕫64 0 = None | i > HS.fromIntegral (HS.maxBound @ℕ8) = None | otherwise = Some $ HS.fromIntegral i instance ToInt ℤ64 where int = HS.fromIntegral instance ToInt64 ℤ64 where int64 = id -instance ToIntO32 ℤ64 where - intO32 i +instance ToIntO32 ℤ64 where + intO32 i | i < HS.fromIntegral (HS.minBound @ℤ32) = None | i > HS.fromIntegral (HS.maxBound @ℤ32) = None | otherwise = Some $ HS.fromIntegral i -instance ToIntO16 ℤ64 where - intO16 i +instance ToIntO16 ℤ64 where + intO16 i | i < HS.fromIntegral (HS.minBound @ℤ16) = None | i > HS.fromIntegral (HS.maxBound @ℤ16) = None | otherwise = Some $ HS.fromIntegral i -instance ToIntO8 ℤ64 where - intO8 i +instance ToIntO8 ℤ64 where + intO8 i | i < HS.fromIntegral (HS.minBound @ℤ8) = None | i > HS.fromIntegral (HS.maxBound @ℤ8) = None | otherwise = Some $ HS.fromIntegral i instance ToRational ℤ64 where rat = HS.fromIntegral -instance ToRationalᴾO ℤ64 where +instance ToRationalᴾO ℤ64 where ratᴾO i | i < 𝕫64 0 = None | otherwise = Some $ HS.fromIntegral i @@ -519,24 +519,24 @@ instance MeetLattice ℤ32 instance Monoid ℤ32 instance ToNatO ℤ32 where - natO i + natO i | i < 𝕫32 0 = None | otherwise = Some $ HS.fromIntegral i instance ToNatO64 ℤ32 where - natO64 i + natO64 i | i < 𝕫32 0 = None | otherwise = Some $ HS.fromIntegral i instance ToNatO32 ℤ32 where - natO32 i + natO32 i | i < 𝕫32 0 = None | otherwise = Some $ HS.fromIntegral i -instance ToNatO16 ℤ32 where - natO16 i +instance ToNatO16 ℤ32 where + natO16 i | i < 𝕫32 0 = None | i > HS.fromIntegral (HS.maxBound @ℕ16) = None | otherwise = Some $ HS.fromIntegral i -instance ToNatO8 ℤ32 where - natO8 i +instance ToNatO8 ℤ32 where + natO8 i | i < 𝕫32 0 = None | i > HS.fromIntegral (HS.maxBound @ℕ8) = None | otherwise = Some $ HS.fromIntegral i @@ -544,19 +544,19 @@ instance ToNatO8 ℤ32 where instance ToInt ℤ32 where int = HS.fromIntegral instance ToInt64 ℤ32 where int64 = HS.fromIntegral instance ToInt32 ℤ32 where int32 = id -instance ToIntO16 ℤ32 where - intO16 i +instance ToIntO16 ℤ32 where + intO16 i | i < HS.fromIntegral (HS.minBound @ℤ16) = None | i > HS.fromIntegral (HS.maxBound @ℤ16) = None | otherwise = Some $ HS.fromIntegral i -instance ToIntO8 ℤ32 where - intO8 i +instance ToIntO8 ℤ32 where + intO8 i | i < HS.fromIntegral (HS.minBound @ℤ8) = None | i > HS.fromIntegral (HS.maxBound @ℤ8) = None | otherwise = Some $ HS.fromIntegral i instance ToRational ℤ32 where rat = HS.fromIntegral -instance ToRationalᴾO ℤ32 where +instance ToRationalᴾO ℤ32 where ratᴾO i | i < 𝕫32 0 = None | otherwise = Some $ HS.fromIntegral i @@ -596,24 +596,24 @@ instance JoinLattice ℤ16 instance MeetLattice ℤ16 instance Monoid ℤ16 -instance ToNatO ℤ16 where - natO i +instance ToNatO ℤ16 where + natO i | i < 𝕫16 0 = None | otherwise = Some $ HS.fromIntegral i -instance ToNatO64 ℤ16 where - natO64 i +instance ToNatO64 ℤ16 where + natO64 i | i < 𝕫16 0 = None | otherwise = Some $ HS.fromIntegral i -instance ToNatO32 ℤ16 where - natO32 i +instance ToNatO32 ℤ16 where + natO32 i | i < 𝕫16 0 = None | otherwise = Some $ HS.fromIntegral i -instance ToNatO16 ℤ16 where - natO16 i +instance ToNatO16 ℤ16 where + natO16 i | i < 𝕫16 0 = None | otherwise = Some $ HS.fromIntegral i -instance ToNatO8 ℤ16 where - natO8 i +instance ToNatO8 ℤ16 where + natO8 i | i < 𝕫16 0 = None | i > HS.fromIntegral (HS.maxBound @ℕ8) = None | otherwise = Some $ HS.fromIntegral i @@ -622,14 +622,14 @@ instance ToInt ℤ16 where int = HS.fromIntegral instance ToInt64 ℤ16 where int64 = HS.fromIntegral instance ToInt32 ℤ16 where int32 = HS.fromIntegral instance ToInt16 ℤ16 where int16 = id -instance ToIntO8 ℤ16 where - intO8 i +instance ToIntO8 ℤ16 where + intO8 i | i < HS.fromIntegral (HS.minBound @ℤ8) = None | i > HS.fromIntegral (HS.maxBound @ℤ8) = None | otherwise = Some $ HS.fromIntegral i instance ToRational ℤ16 where rat = HS.fromIntegral -instance ToRationalᴾO ℤ16 where +instance ToRationalᴾO ℤ16 where ratᴾO i | i < 𝕫16 0 = None | otherwise = Some $ HS.fromIntegral i @@ -670,23 +670,23 @@ instance MeetLattice ℤ8 instance Monoid ℤ8 instance ToNatO ℤ8 where - natO i + natO i | i < 𝕫8 0 = None | otherwise = Some $ HS.fromIntegral i instance ToNatO64 ℤ8 where - natO64 i + natO64 i | i < 𝕫8 0 = None | otherwise = Some $ HS.fromIntegral i instance ToNatO32 ℤ8 where - natO32 i + natO32 i | i < 𝕫8 0 = None | otherwise = Some $ HS.fromIntegral i instance ToNatO16 ℤ8 where - natO16 i + natO16 i | i < 𝕫8 0 = None | otherwise = Some $ HS.fromIntegral i instance ToNatO8 ℤ8 where - natO8 i + natO8 i | i < 𝕫8 0 = None | otherwise = Some $ HS.fromIntegral i @@ -697,7 +697,7 @@ instance ToInt16 ℤ8 where int16 = HS.fromIntegral instance ToInt8 ℤ8 where int8 = id instance ToRational ℤ8 where rat = HS.fromIntegral -instance ToRationalᴾO ℤ8 where +instance ToRationalᴾO ℤ8 where ratᴾO i | i < 𝕫8 0 = None | otherwise = Some $ HS.fromIntegral i @@ -777,10 +777,10 @@ instance ToIntO8 ℚ where | otherwise = intO8 $ numer q instance ToRational ℚ where rat = id -instance ToRationalᴾO ℚ where +instance ToRationalᴾO ℚ where ratᴾO q | numer q < 𝕫 0 = None - | otherwise = Some $ HS.fromRational q + | otherwise = Some $ HS.fromRational q instance ToDouble ℚ where dbl = HS.fromRational instance ToDoubleᴾO ℚ where @@ -789,7 +789,7 @@ instance ToDoubleᴾO ℚ where | otherwise = Some $ 𝔻ᴾ $ HS.fromRational q instance ToNumber ℚ where num = Rational -instance ToNumberᴾO ℚ where +instance ToNumberᴾO ℚ where numᴾO q = case ratᴾO q of None → None Some qᴾ → Some $ Rationalᴾ qᴾ @@ -803,7 +803,7 @@ instance One ℚᴾ where one = 𝕢ᴾ 1 instance Times ℚᴾ where (×) = (HS.*) instance Divide ℚᴾ where (/) = (HS./) instance Pon ℚᴾ where (^^) = (HS.^) - + instance Bot ℚᴾ where bot = 𝕢ᴾ 0 instance Join ℚᴾ where (⊔) = (⩏) instance Meet ℚᴾ where (⊓) = (⩎) @@ -954,14 +954,14 @@ instance ToIntO8 𝔻 where False → None instance ToRational 𝔻 where rat = HS.realToFrac -instance ToRationalᴾO 𝔻 where +instance ToRationalᴾO 𝔻 where ratᴾO d | d < 0.0 = None | otherwise = Some $ HS.realToFrac d instance ToDouble 𝔻 where dbl = id -instance ToDoubleᴾO 𝔻 where - dblᴾO d +instance ToDoubleᴾO 𝔻 where + dblᴾO d | d < 0.0 = None | otherwise = Some $ 𝔻ᴾ d @@ -991,7 +991,7 @@ instance Log 𝔻ᴾ where log = HS.log instance Efn 𝔻ᴾ where efn = HS.exp instance Sin 𝔻ᴾ where sin = HS.sin instance Cos 𝔻ᴾ where cos = HS.cos - + instance Bot 𝔻ᴾ where bot = 𝕕ᴾ 0.0 instance Join 𝔻ᴾ where (⊔) = (⩏) instance Top 𝔻ᴾ where top = 𝕕ᴾ 1.0 / 𝕕ᴾ 0.0 @@ -1067,7 +1067,7 @@ instance ToIntO8 𝔻ᴾ where False → None instance ToRational 𝔻ᴾ where rat = HS.toRational -instance ToRationalᴾO 𝔻ᴾ where +instance ToRationalᴾO 𝔻ᴾ where ratᴾO d | d < 𝕕ᴾ 0.0 = None | otherwise = Some $ HS.fromRational $ HS.toRational d @@ -1101,33 +1101,33 @@ numberBOpᴾ _oZ _oQ oD (Doubleᴾ d₁) (Natural i₂) = oD d₁ (dblᴾ i numberBOpᴾ _oZ _oQ oD (Rationalᴾ q₁) (Doubleᴾ d₂) = oD (dblᴾ q₁) d₂ numberBOpᴾ _oZ _oQ oD (Doubleᴾ d₁) (Rationalᴾ q₂) = oD d₁ (dblᴾ q₂) -instance Zero ℝ where +instance Zero ℝ where zero = Integer zero -instance Plus ℝ where +instance Plus ℝ where (+) = numberBOp (Integer ∘∘ (+)) (Rational ∘∘ (+)) $ Double ∘∘ (+) -instance Minus ℝ where +instance Minus ℝ where (-) = numberBOp (Integer ∘∘ (-)) (Rational ∘∘ (-)) $ Double ∘∘ (-) -instance One ℝ where +instance One ℝ where one = Integer one -instance Times ℝ where +instance Times ℝ where (×) = numberBOp (Integer ∘∘ (×)) (Rational ∘∘ (×)) $ Double ∘∘ (×) -instance Divide ℝ where - (/) = numberBOp (\ i₁ i₂ → Rational $ rat i₁ / rat i₂) - (Rational ∘∘ (/)) +instance Divide ℝ where + (/) = numberBOp (\ i₁ i₂ → Rational $ rat i₁ / rat i₂) + (Rational ∘∘ (/)) $ Double ∘∘ (/) -instance Pon ℝ where +instance Pon ℝ where Integer m ^^ n = Integer $ m ^^ n Rational q ^^ n = Rational $ q ^^ n Double d ^^ n = Double $ d ^^ n -instance Pow ℝ where - (^) = numberBOp (\ i₁ i₂ → Double $ dbl i₁ ^ dbl i₂) - (\ q₁ q₂ → Double $ dbl q₁ ^ dbl q₂) +instance Pow ℝ where + (^) = numberBOp (\ i₁ i₂ → Double $ dbl i₁ ^ dbl i₂) + (\ q₁ q₂ → Double $ dbl q₁ ^ dbl q₂) $ Double ∘∘ (^) instance Root ℝ where root (Integer i) = Double $ root $ dbl i root (Rational q) = Double $ root $ dbl q root (Double d) = Double $ root d -instance Log ℝ where +instance Log ℝ where log (Integer i) = Double $ log $ dbl i log (Rational q) = Double $ log $ dbl q log (Double d) = Double $ log d @@ -1212,29 +1212,29 @@ instance ToDoubleᴾO ℝ where dblᴾO (Rational q) = dblᴾO q dblᴾO (Double d) = dblᴾO d -instance Zero ℝᴾ where +instance Zero ℝᴾ where zero = Natural zero -instance Plus ℝᴾ where +instance Plus ℝᴾ where (+) = numberBOpᴾ (Natural ∘∘ (+)) (Rationalᴾ ∘∘ (+)) (Doubleᴾ ∘∘ (+)) -instance Minus ℝᴾ where +instance Minus ℝᴾ where (-) = numberBOpᴾ (Natural ∘∘ (-)) (Rationalᴾ ∘∘ (-)) (Doubleᴾ ∘∘ (-)) -instance One ℝᴾ where +instance One ℝᴾ where one = Natural one -instance Times ℝᴾ where +instance Times ℝᴾ where (×) = numberBOpᴾ (Natural ∘∘ (×)) (Rationalᴾ ∘∘ (×)) (Doubleᴾ ∘∘ (×)) -instance Divide ℝᴾ where +instance Divide ℝᴾ where (/) = numberBOpᴾ (\ n₁ n₂ → Rationalᴾ $ ratᴾ n₁ / ratᴾ n₂) (Rationalᴾ ∘∘ (/)) (Doubleᴾ ∘∘ (/)) -instance Pon ℝᴾ where +instance Pon ℝᴾ where Natural m ^^ n = Natural $ m ^^ n Rationalᴾ q ^^ n = Rationalᴾ $ q ^^ n Doubleᴾ d ^^ n = Doubleᴾ $ d ^^ n -instance Pow ℝᴾ where +instance Pow ℝᴾ where (^) = numberBOpᴾ (Natural ∘∘ (^)) (\ qᴾ₁ qᴾ₂ → Doubleᴾ $ dblᴾ qᴾ₁ ^ dblᴾ qᴾ₂) (Doubleᴾ ∘∘ (^)) instance Root ℝᴾ where root (Natural n) = Doubleᴾ $ root $ dblᴾ n root (Rationalᴾ q) = Doubleᴾ $ root $ dblᴾ q root (Doubleᴾ d) = Doubleᴾ $ root d -instance Log ℝᴾ where +instance Log ℝᴾ where log (Natural n) = Doubleᴾ $ log $ dblᴾ n log (Rationalᴾ q) = Doubleᴾ $ log $ dblᴾ q log (Doubleᴾ d) = Doubleᴾ $ log d diff --git a/src/UVMHS/Core/Data/Choice.hs b/src/UVMHS/Core/Data/Choice.hs index 9d5eb330..f3dd4c3c 100644 --- a/src/UVMHS/Core/Data/Choice.hs +++ b/src/UVMHS/Core/Data/Choice.hs @@ -3,11 +3,11 @@ module UVMHS.Core.Data.Choice where import UVMHS.Core.Init import UVMHS.Core.Classes -instance Functor ((∨) a) where +instance Functor ((∨) a) where map f = \case Inl x → Inl x Inr y → Inr $ f y -instance Return ((∨) a) where +instance Return ((∨) a) where return = Inr instance Bind ((∨) a) where Inl x ≫= _ = Inl x @@ -20,14 +20,14 @@ instance FunctorM ((∨) a) where y' ← f y return $ Inr y' -instance (Null b) ⇒ Null (a ∨ b) where +instance (Null b) ⇒ Null (a ∨ b) where null = Inr null -instance (Append a,Append b) ⇒ Append (a ∨ b) where +instance (Append a,Append b) ⇒ Append (a ∨ b) where Inl x ⧺ Inl y = Inl (x ⧺ y) Inl x ⧺ Inr _ = Inl x Inr _ ⧺ Inl y = Inl y Inr x ⧺ Inr y = Inr (x ⧺ y) -instance (Append a,Monoid b) ⇒ Monoid (a ∨ b) +instance (Append a,Monoid b) ⇒ Monoid (a ∨ b) elimChoice ∷ (a → c) → (b → c) → a ∨ b → c elimChoice f₁ f₂ = \case diff --git a/src/UVMHS/Core/Data/Dict.hs b/src/UVMHS/Core/Data/Dict.hs index 865412d5..4a4201ce 100644 --- a/src/UVMHS/Core/Data/Dict.hs +++ b/src/UVMHS/Core/Data/Dict.hs @@ -24,7 +24,7 @@ infixl 6 ⩍ -- GENERIC CLASS -- ------------------- -class +class ( Set k s , FunctorM d , OFunctorM d @@ -127,7 +127,7 @@ assoc = foldr dø $ curry dadd dø𝐷 ∷ ∀ k a. k ⇰ a dø𝐷 = coerce @(Map.Map k a) Map.empty - + (↦♭) ∷ ∀ k a. k → a → k ⇰ a (↦♭) = coerce @(k → a → Map.Map k a) Map.singleton @@ -165,19 +165,19 @@ dsdiffBy𝐷 = coerce @((a → b → 𝑂 a) → Map.Map k a → Map.Map k b → (⩍♭) = coerce @(Map.Map k a → Map.Map k a → Map.Map k a) Map.intersection (⧅♭) ∷ ∀ k a. (Ord k,Eq a) ⇒ k ⇰ a → k ⇰ a → k ⇰ a -(⧅♭) = coerce @(Map.Map k a → Map.Map k a → Map.Map k a) $ Map.differenceWith $ \ x y → +(⧅♭) = coerce @(Map.Map k a → Map.Map k a → Map.Map k a) $ Map.differenceWith $ \ x y → if x ≡ y then HS.Nothing else HS.Just x dminView𝐷 ∷ ∀ k a. k ⇰ a → 𝑂 (k ∧ a ∧ (k ⇰ a)) -dminView𝐷 = coerce @(Map.Map k a → 𝑂 (k ∧ a ∧ Map.Map k a)) $ +dminView𝐷 = coerce @(Map.Map k a → 𝑂 (k ∧ a ∧ Map.Map k a)) $ frhs ∘ Map.minViewWithKey dmaxView𝐷 ∷ ∀ k a. k ⇰ a → 𝑂 (k ∧ a ∧ (k ⇰ a)) -dmaxView𝐷 = coerce @(Map.Map k a → 𝑂 (k ∧ a ∧ Map.Map k a)) $ +dmaxView𝐷 = coerce @(Map.Map k a → 𝑂 (k ∧ a ∧ Map.Map k a)) $ frhs ∘ Map.maxViewWithKey dkeyView𝐷 ∷ ∀ k a. (Ord k) ⇒ k → k ⇰ a → 𝑂 (a ∧ (k ⇰ a)) -dkeyView𝐷 = coerce @(k → Map.Map k a → 𝑂 (a ∧ Map.Map k a)) $ \ k d → +dkeyView𝐷 = coerce @(k → Map.Map k a → 𝑂 (a ∧ Map.Map k a)) $ \ k d → let xM :* d' = frhs $ Map.updateLookupWithKey (const $ const HS.Nothing) k d in map (:* d') xM @@ -205,25 +205,25 @@ dvals𝐷 = coerce @(Map.Map k a → 𝐼 a) $ iter ∘ Map.elems -- CLASS DEFINITIONS: FunctorM -- mapM𝐷 ∷ ∀ m k a b. (Monad m) ⇒ (a → m b) → k ⇰ a → m (k ⇰ b) -mapM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ +mapM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ coerce @((a → m b) → Map.Map k a → m (Map.Map k b)) HS.mapM -- CLASS DEFINITIONS: OFunctorM -- omapM𝐷 ∷ ∀ m k a b. (Monad m) ⇒ (a → m (𝑂 b)) → k ⇰ a → m (k ⇰ b) -omapM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ - coerce @((a → m (𝑂 b)) → Map.Map k a → m (Map.Map k b)) $ \ f → +omapM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ + coerce @((a → m (𝑂 b)) → Map.Map k a → m (Map.Map k b)) $ \ f → Map.traverseMaybeWithKey $ const $ map tohs ∘ f -- CLASS DEFINITIONS: KFunctorM -- kmapM𝐷 ∷ ∀ m k a b. (Monad m) ⇒ (k → a → m b) → k ⇰ a → m (k ⇰ b) -kmapM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ +kmapM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ coerce @((k → a → m b) → Map.Map k a → m (Map.Map k b)) Map.traverseWithKey kmapAtM𝐷 ∷ ∀ m k a. (Monad m,Ord k) ⇒ k → (a → m a) → k ⇰ a → m (k ⇰ a) -kmapAtM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ - coerce @(k → (a → m a) → Map.Map k a → m (Map.Map k a)) $ \ k f → +kmapAtM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ + coerce @(k → (a → m a) → Map.Map k a → m (Map.Map k a)) $ \ k f → flip Map.alterF k $ \case HS.Nothing → return HS.Nothing HS.Just x → HS.Just ^$ f x @@ -231,49 +231,49 @@ kmapAtM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ -- CLASS DEFINITIONS: OKFunctorM -- okmapM𝐷 ∷ ∀ m k a b. (Monad m) ⇒ (k → a → m (𝑂 b)) → k ⇰ a → m (k ⇰ b) -okmapM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ - coerce @((k → a → m (𝑂 b)) → Map.Map k a → m (Map.Map k b)) $ \ f → +okmapM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ + coerce @((k → a → m (𝑂 b)) → Map.Map k a → m (Map.Map k b)) $ \ f → Map.traverseMaybeWithKey $ map tohs ∘∘ f okmapAtM𝐷 ∷ ∀ m k a. (Monad m,Ord k) ⇒ k → (𝑂 a → m (𝑂 a)) → k ⇰ a → m (k ⇰ a) -okmapAtM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ - coerce @(k → (𝑂 a → m (𝑂 a)) → Map.Map k a → m (Map.Map k a)) $ \ k f → +okmapAtM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ + coerce @(k → (𝑂 a → m (𝑂 a)) → Map.Map k a → m (Map.Map k a)) $ \ k f → flip Map.alterF k $ tohs ^∘ f ∘ frhs -- CLASS DEFINITIONS: BiFunctorM -- bimapM𝐷 ∷ ∀ m k a b c. (Monad m,Ord k) ⇒ (a → m c) → (b → m c) → (a → b → m c) → k ⇰ a → k ⇰ b → m (k ⇰ c) -bimapM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ - coerce @((a → m c) → (b → m c) → (a → b → m c) → Map.Map k a → Map.Map k b → m (Map.Map k c)) $ \ f₁ f₂ f₃ → - Map.mergeA (Map.traverseMissing $ const f₁) - (Map.traverseMissing $ const f₂) $ +bimapM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ + coerce @((a → m c) → (b → m c) → (a → b → m c) → Map.Map k a → Map.Map k b → m (Map.Map k c)) $ \ f₁ f₂ f₃ → + Map.mergeA (Map.traverseMissing $ const f₁) + (Map.traverseMissing $ const f₂) $ Map.zipWithAMatched $ const f₃ -- CLASS DEFINITIONS: OBiFunctorM -- obimapM𝐷 ∷ ∀ m k a b c. (Monad m,Ord k) ⇒ (a → m (𝑂 c)) → (b → m (𝑂 c)) → (a → b → m (𝑂 c)) → k ⇰ a → k ⇰ b → m (k ⇰ c) -obimapM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ - coerce @((a → m (𝑂 c)) → (b → m (𝑂 c)) → (a → b → m (𝑂 c)) → Map.Map k a → Map.Map k b → m (Map.Map k c)) $ \ f₁ f₂ f₃ → - Map.mergeA (Map.traverseMaybeMissing $ const $ map tohs ∘ f₁) - (Map.traverseMaybeMissing $ const $ map tohs ∘ f₂) $ +obimapM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ + coerce @((a → m (𝑂 c)) → (b → m (𝑂 c)) → (a → b → m (𝑂 c)) → Map.Map k a → Map.Map k b → m (Map.Map k c)) $ \ f₁ f₂ f₃ → + Map.mergeA (Map.traverseMaybeMissing $ const $ map tohs ∘ f₁) + (Map.traverseMaybeMissing $ const $ map tohs ∘ f₂) $ Map.zipWithMaybeAMatched $ const $ map tohs ∘∘ f₃ -- CLASS DEFINITIONS: KBiFunctorM -- kbimapM𝐷 ∷ ∀ m k a b c. (Monad m,Ord k) ⇒ (k → a → m c) → (k → b → m c) → (k → a → b → m c) → k ⇰ a → k ⇰ b → m (k ⇰ c) -kbimapM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ - coerce @((k → a → m c) → (k → b → m c) → (k → a → b → m c) → Map.Map k a → Map.Map k b → m (Map.Map k c)) $ \ f₁ f₂ f₃ → - Map.mergeA (Map.traverseMissing f₁) - (Map.traverseMissing f₂) $ +kbimapM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ + coerce @((k → a → m c) → (k → b → m c) → (k → a → b → m c) → Map.Map k a → Map.Map k b → m (Map.Map k c)) $ \ f₁ f₂ f₃ → + Map.mergeA (Map.traverseMissing f₁) + (Map.traverseMissing f₂) $ Map.zipWithAMatched f₃ -- CLASS DEFINITIONS: KBiFunctorM -- okbimapM𝐷 ∷ ∀ m k a b c. (Monad m,Ord k) ⇒ (k → a → m (𝑂 c)) → (k → b → m (𝑂 c)) → (k → a → b → m (𝑂 c)) → k ⇰ a → k ⇰ b → m (k ⇰ c) okbimapM𝐷 = with (tohsMonad @m) HS.$ with (fcoercibleW_UNSAFE @m) HS.$ - coerce @((k → a → m (𝑂 c)) → (k → b → m (𝑂 c)) → (k → a → b → m (𝑂 c)) → Map.Map k a → Map.Map k b → m (Map.Map k c)) $ \ f₁ f₂ f₃ → - Map.mergeA (Map.traverseMaybeMissing $ map tohs ∘∘ f₁) - (Map.traverseMaybeMissing $ map tohs ∘∘ f₂) $ + coerce @((k → a → m (𝑂 c)) → (k → b → m (𝑂 c)) → (k → a → b → m (𝑂 c)) → Map.Map k a → Map.Map k b → m (Map.Map k c)) $ \ f₁ f₂ f₃ → + Map.mergeA (Map.traverseMaybeMissing $ map tohs ∘∘ f₁) + (Map.traverseMaybeMissing $ map tohs ∘∘ f₂) $ Map.zipWithMaybeAMatched $ map tohs ∘∘∘ f₃ -- CLASS DEFINITIONS: Functor -- @@ -305,33 +305,33 @@ okmapAt𝐷 = coerce @(k → (𝑂 a → 𝑂 a) → Map.Map k a → Map.Map k a -- CLASS DEFINITIONS: BiFunctor -- bimap𝐷 ∷ ∀ k a b c. (Ord k) ⇒ (a → c) → (b → c) → (a → b → c) → k ⇰ a → k ⇰ b → k ⇰ c -bimap𝐷 = coerce @((a → c) → (b → c) → (a → b → c) → Map.Map k a → Map.Map k b → Map.Map k c) $ \ f₁ f₂ f₃ → - Map.merge (Map.mapMissing $ const f₁) - (Map.mapMissing $ const f₂) $ +bimap𝐷 = coerce @((a → c) → (b → c) → (a → b → c) → Map.Map k a → Map.Map k b → Map.Map k c) $ \ f₁ f₂ f₃ → + Map.merge (Map.mapMissing $ const f₁) + (Map.mapMissing $ const f₂) $ Map.zipWithMatched $ const f₃ -- CLASS DEFINITIONS: OBiFunctor -- obimap𝐷 ∷ ∀ k a b c. (Ord k) ⇒ (a → 𝑂 c) → (b → 𝑂 c) → (a → b → 𝑂 c) → k ⇰ a → k ⇰ b → k ⇰ c -obimap𝐷 = coerce @((a → 𝑂 c) → (b → 𝑂 c) → (a → b → 𝑂 c) → Map.Map k a → Map.Map k b → Map.Map k c) $ \ f₁ f₂ f₃ → - Map.merge (Map.mapMaybeMissing $ const $ tohs ∘ f₁) - (Map.mapMaybeMissing $ const $ tohs ∘ f₂) $ +obimap𝐷 = coerce @((a → 𝑂 c) → (b → 𝑂 c) → (a → b → 𝑂 c) → Map.Map k a → Map.Map k b → Map.Map k c) $ \ f₁ f₂ f₃ → + Map.merge (Map.mapMaybeMissing $ const $ tohs ∘ f₁) + (Map.mapMaybeMissing $ const $ tohs ∘ f₂) $ Map.zipWithMaybeMatched $ const $ tohs ∘∘ f₃ -- CLASS DEFINITIONS: KBiFunctor -- kbimap𝐷 ∷ ∀ k a b c. (Ord k) ⇒ (k → a → c) → (k → b → c) → (k → a → b → c) → k ⇰ a → k ⇰ b → k ⇰ c -kbimap𝐷 = coerce @((k → a → c) → (k → b → c) → (k → a → b → c) → Map.Map k a → Map.Map k b → Map.Map k c) $ \ f₁ f₂ f₃ → - Map.merge (Map.mapMissing f₁) - (Map.mapMissing f₂) $ +kbimap𝐷 = coerce @((k → a → c) → (k → b → c) → (k → a → b → c) → Map.Map k a → Map.Map k b → Map.Map k c) $ \ f₁ f₂ f₃ → + Map.merge (Map.mapMissing f₁) + (Map.mapMissing f₂) $ Map.zipWithMatched f₃ -- CLASS DEFINITIONS: OKBiFunctor -- okbimap𝐷 ∷ ∀ k a b c. (Ord k) ⇒ (k → a → 𝑂 c) → (k → b → 𝑂 c) → (k → a → b → 𝑂 c) → k ⇰ a → k ⇰ b → (k ⇰ c) -okbimap𝐷 = coerce @((k → a → 𝑂 c) → (k → b → 𝑂 c) → (k → a → b → 𝑂 c) → Map.Map k a → Map.Map k b → Map.Map k c) $ \ f₁ f₂ f₃ → - Map.merge (Map.mapMaybeMissing $ tohs ∘∘ f₁) - (Map.mapMaybeMissing $ tohs ∘∘ f₂) $ +okbimap𝐷 = coerce @((k → a → 𝑂 c) → (k → b → 𝑂 c) → (k → a → b → 𝑂 c) → Map.Map k a → Map.Map k b → Map.Map k c) $ \ f₁ f₂ f₃ → + Map.merge (Map.mapMaybeMissing $ tohs ∘∘ f₁) + (Map.mapMaybeMissing $ tohs ∘∘ f₂) $ Map.zipWithMaybeMatched $ tohs ∘∘∘ f₃ -- CLASS DEFINITIONS: CSized -- @@ -462,7 +462,7 @@ instance (Ord k) ⇒ Single (k ∧ a) (k ⇰ a) wher instance (Ord k) ⇒ Lookup k a (k ⇰ a) where (⋕?) = lookup𝐷 instance Null (k ⇰ a) where null = dø𝐷 instance (Ord k,Append a) ⇒ Append (k ⇰ a) where (⧺) = append𝐷 -instance (Ord k,Append a) ⇒ Monoid (k ⇰ a) +instance (Ord k,Append a) ⇒ Monoid (k ⇰ a) instance (Ord k,Null k,Null a) ⇒ Unit (k ⇰ a) where unit = unit𝐷 instance (Ord k,Append k,Append a,Cross a) ⇒ Cross (k ⇰ a) where (⨳) = cross𝐷 instance (Ord k,Monoid k,Prodoid a) ⇒ Prodoid (k ⇰ a) @@ -524,14 +524,14 @@ data StdESD (x ∷ ★) newtype instance Elem (StdESD a) = StdESDElm { unStdESDElm ∷ a } deriving (Eq,Ord) newtype instance ESet (StdESD e) = StdESDSet { unStdESDSet ∷ 𝑃 e } - deriving + deriving ( CSized,Eq,Ord , Null,Append,Monoid , POrd , Bot,Join,JoinLattice,Meet,Difference ) newtype instance EDct (StdESD k) a = StdESDDct { unStdESDDct ∷ k ⇰ a } - deriving + deriving ( Eq,Ord , Null,Append,Monoid , Bot,Join,JoinLattice @@ -620,28 +620,28 @@ instance (Ord k) ⇒ Single (Elem (StdESD k) ∧ a) (EDct (StdESD k) a) where -- unionWithOn𝐷 ∷ (Ord k) ⇒ k ⇰ a → k ⇰ a → (a → a → a) → k ⇰ a -- unionWithOn𝐷 = rotateL unionWith𝐷 --- +-- -- unionsWith𝐷 ∷ (Ord k,ToIter (k ⇰ a) t) ⇒ (a → a → a) → t → k ⇰ a -- unionsWith𝐷 = fold dø𝐷 ∘ unionWith𝐷 --- +-- -- kunionWith𝐷 ∷ ∀ k a. (Ord k) ⇒ (k → a → a → a) → k ⇰ a → k ⇰ a → k ⇰ a -- kunionWith𝐷 = coerce @((k → a → a → a) → Map.Map k a → Map.Map k a → Map.Map k a) Map.unionWithKey --- +-- -- kunionWithOn𝐷 ∷ (Ord k) ⇒ k ⇰ a → k ⇰ a → (k → a → a → a) → k ⇰ a -- kunionWithOn𝐷 = rotateL kunionWith𝐷 --- +-- -- kunionsWith𝐷 ∷ (Ord k,ToIter (k ⇰ a) t) ⇒ (k → a → a → a) → t → k ⇰ a -- kunionsWith𝐷 = fold dø𝐷 ∘ kunionWith𝐷 --- --- interWithOn𝐷 ∷ (Ord k) ⇒ k ⇰ a → k ⇰ b → (a → b → c) → k ⇰ c +-- +-- interWithOn𝐷 ∷ (Ord k) ⇒ k ⇰ a → k ⇰ b → (a → b → c) → k ⇰ c -- interWithOn𝐷 = rotateL interWith𝐷 --- +-- -- intersWith𝐷 ∷ (Ord k,ToIter (k ⇰ a) t) ⇒ (a → a → a) → t → k ⇰ a -- intersWith𝐷 = fold dø𝐷 ∘ interWith𝐷 --- +-- -- diffnWithOn𝐷 ∷ (Ord k) ⇒ k ⇰ a → k ⇰ a → (a → a → a) → k ⇰ a -- diffnWithOn𝐷 = rotateL diffnWith𝐷 --- +-- -- diffnsWith𝐷 ∷ (Ord k,ToIter (k ⇰ a) t) ⇒ (a → a → a) → t → k ⇰ a -- diffnsWith𝐷 = foldr dø𝐷 ∘ diffnWith𝐷 @@ -656,7 +656,7 @@ instance (Ord k) ⇒ Single (Elem (StdESD k) ∧ a) (EDct (StdESD k) a) where --- mapOnKeyWith ∷ (Ord k) ⇒ (a → a) → k → k ⇰ a → k ⇰ a --- mapOnKeyWith f k = 𝐷 ∘ Map.adjust f k ∘ un𝐷 ---- +--- --- mapOnKey ∷ (Ord k) ⇒ k → (a → a) → k ⇰ a → k ⇰ a --- mapOnKey = flip mapOnKeyWith @@ -668,4 +668,3 @@ instance (Ord k) ⇒ Single (Elem (StdESD k) ∧ a) (EDct (StdESD k) a) where -- djoin ∷ (Ord k,Ord v₁,Ord v₂) ⇒ k ⇰ 𝑃 v₁ → k ⇰ 𝑃 v₂ → k ⇰ 𝑃 (v₁ ∧ v₂) -- djoin = interWith $ \ vs₁ vs₂ → pow $ zipWith (:*) vs₁ vs₂ - diff --git a/src/UVMHS/Core/Data/Function.hs b/src/UVMHS/Core/Data/Function.hs index e7016ed1..aa793099 100644 --- a/src/UVMHS/Core/Data/Function.hs +++ b/src/UVMHS/Core/Data/Function.hs @@ -3,11 +3,11 @@ module UVMHS.Core.Data.Function where import UVMHS.Core.Init import UVMHS.Core.Classes -instance Functor ((→) r) where +instance Functor ((→) r) where map f g = f ∘ g -instance Return ((→) r) where +instance Return ((→) r) where return = const -instance Bind ((→) r) where +instance Bind ((→) r) where f ≫= k = \ r → k (f r) r instance Monad ((→) r) @@ -28,7 +28,7 @@ pipe ∷ (a → b) → (b → c) → a → c pipe = flip (∘) iterateWith ∷ (a → 𝑂 a) → a → a -iterateWith f = +iterateWith f = let loop' x = case f x of None → x Some x' → loop' x' diff --git a/src/UVMHS/Core/Data/Iter.hs b/src/UVMHS/Core/Data/Iter.hs index 4399ef89..bd062b0c 100644 --- a/src/UVMHS/Core/Data/Iter.hs +++ b/src/UVMHS/Core/Data/Iter.hs @@ -37,7 +37,7 @@ empty𝐼 ∷ 𝐼 a empty𝐼 = null𝐼 cons𝐼 ∷ a → 𝐼 a → 𝐼 a -cons𝐼 x xs = 𝐼 HS.$ \ f i 𝓀 → +cons𝐼 x xs = 𝐼 HS.$ \ f i 𝓀 → f x i $ \ i' → un𝐼 xs f i' 𝓀 @@ -51,7 +51,7 @@ zip ∷ (ToIter a t₁,ToIter b t₂) ⇒ t₁ → t₂ → 𝐼 (a ∧ b) zip = zipWith (:*) snoc𝐼 ∷ 𝐼 a → a → 𝐼 a -snoc𝐼 xs x = 𝐼 HS.$ \ f i 𝓀 → +snoc𝐼 xs x = 𝐼 HS.$ \ f i 𝓀 → un𝐼 xs f i $ \ i' → f x i' 𝓀 @@ -213,16 +213,16 @@ mfoldrWithFrom = flip mfoldr eachWith ∷ (Monad m,ToIter a t) ⇒ (a → m ()) → t → m () eachWith f = mfoldFromWith () $ const ∘ f -eachOn ∷ (Monad m,ToIter a t) ⇒ t → (a → m ()) → m () +eachOn ∷ (Monad m,ToIter a t) ⇒ t → (a → m ()) → m () eachOn = flip eachWith eachkWith ∷ (Monad m,ToIter a t) ⇒ (a → (m () → m ()) → m ()) → t → m () eachkWith f = mfoldkFromWith () $ const ∘ f -eachkOn ∷ (Monad m,ToIter a t) ⇒ t → (a → (m () → m ()) → m ()) → m () +eachkOn ∷ (Monad m,ToIter a t) ⇒ t → (a → (m () → m ()) → m ()) → m () eachkOn = flip eachkWith -exec ∷ (Monad m,ToIter (m ()) t) ⇒ t → m () +exec ∷ (Monad m,ToIter (m ()) t) ⇒ t → m () exec = eachWith id sum ∷ (ToIter a t,Additive a) ⇒ t → a @@ -288,10 +288,10 @@ reverse ∷ (ToIter a t) ⇒ t → 𝐼 a reverse xs = 𝐼 HS.$ \ f i₀ 𝓀₀ → un𝐼 (iter xs) (\ x 𝓀 m𝓀 → m𝓀 $ \ i → f x i 𝓀) 𝓀₀ id i₀ replicateI ∷ ∀ n a. (Eq n,Zero n,One n,Plus n) ⇒ n → (n → a) → 𝐼 a -replicateI n₀ g = 𝐼 HS.$ \ f → flip $ \ 𝓀 → +replicateI n₀ g = 𝐼 HS.$ \ f → flip $ \ 𝓀 → let loop n i | n ≡ n₀ = 𝓀 i - | otherwise = + | otherwise = f (g n) i $ \ i' → loop (succ n) i' in loop zero @@ -300,10 +300,10 @@ replicate ∷ ∀ n a. (Eq n,Zero n,One n,Plus n) ⇒ n → a → 𝐼 a replicate n = replicateI n ∘ const build ∷ ∀ n a. (Eq n,Zero n,One n,Plus n) ⇒ n → a → (a → a) → 𝐼 a -build n₀ x₀ g = 𝐼 HS.$ \ f → flip $ \ 𝓀 → +build n₀ x₀ g = 𝐼 HS.$ \ f → flip $ \ 𝓀 → let loop n x i | n ≡ n₀ = 𝓀 i - | otherwise = + | otherwise = f x i $ \ i' → loop (succ n) (g x) i' in loop zero x₀ @@ -315,11 +315,11 @@ upto ∷ (Eq n,Zero n,One n,Plus n) ⇒ n → 𝐼 n upto n = build n zero succ reiter ∷ (ToIter a t) ⇒ s → (a → s → (s ∧ b)) → t → 𝐼 b -reiter s₀ f xs = - 𝐼 HS.$ \ g i₀ 𝓀₀ → - snd $ run𝐼On (iter xs) (\ (s :* i) → s :* 𝓀₀ i) (s₀ :* i₀) $ \ x (s :* i) 𝓀 → +reiter s₀ f xs = + 𝐼 HS.$ \ g i₀ 𝓀₀ → + snd $ run𝐼On (iter xs) (\ (s :* i) → s :* 𝓀₀ i) (s₀ :* i₀) $ \ x (s :* i) 𝓀 → let s' :* y = f x s - in (s' :*) $ g y i $ \ i' → + in (s' :*) $ g y i $ \ i' → snd $ 𝓀 $ s' :* i' withIndex ∷ ∀ n t a. (Zero n,One n,Plus n,ToIter a t) ⇒ t → 𝐼 (n ∧ a) @@ -329,17 +329,17 @@ withFirst ∷ (ToIter a t) ⇒ t → 𝐼 (𝔹 ∧ a) withFirst = reiter True $ \ x b → False :* (b :* x) mapFirst ∷ (ToIter a t) ⇒ (a → a) → t → 𝐼 a -mapFirst f = reiter True $ \ x b → - let x' = if b then f x else x +mapFirst f = reiter True $ \ x b → + let x' = if b then f x else x in False :* x' mapAfterFirst ∷ (ToIter a t) ⇒ (a → a) → t → 𝐼 a -mapAfterFirst f = reiter True $ \ x b → - let x' = if b then x else f x +mapAfterFirst f = reiter True $ \ x b → + let x' = if b then x else f x in False :* x' keepN ∷ (ToIter a t,Eq n,Zero n,One n,Plus n) ⇒ n → t → 𝐼 a -keepN n₀ xs = 𝐼 HS.$ \ f i₀ 𝓀₀ → +keepN n₀ xs = 𝐼 HS.$ \ f i₀ 𝓀₀ → let g x (n :* i) 𝓀 = (succ n :*) $ if n ≡ n₀ then 𝓀₀ i @@ -360,7 +360,7 @@ mapBeforeLast f = map (\ (b :* x) → case b of {True → x;False → f x}) ∘ filterMap ∷ (ToIter a t) ⇒ (a → 𝑂 b) → t → 𝐼 b filterMap f xs = 𝐼 HS.$ \ g → - un𝐼 (iter xs) $ \ x i 𝓀 → + un𝐼 (iter xs) $ \ x i 𝓀 → case f x of None → 𝓀 i Some y → g y i 𝓀 @@ -377,9 +377,9 @@ filterOn = flip filter inbetween ∷ (ToIter a t) ⇒ a → t → 𝐼 a inbetween xⁱ xs = 𝐼 HS.$ \ f → un𝐼 (withFirst $ iter xs) $ \ (b :* x) i 𝓀 → - if b + if b then f x i 𝓀 - else + else f xⁱ i $ \ i' → f x i' 𝓀 @@ -471,7 +471,7 @@ dropWhile p xs₀ = instance All () where all = single () -instance All 𝔹 where +instance All 𝔹 where all = iter [True,False] instance (All a) ⇒ All (𝑂 a) where @@ -480,7 +480,7 @@ instance (All a) ⇒ All (𝑂 a) where instance (All a,All b) ⇒ All (a ∨ b) where all = map Inl all ⧺ map Inr all -instance (All a,All b) ⇒ All (a ∧ b) where +instance (All a,All b) ⇒ All (a ∧ b) where all = do x ← all ; y ← all ; return $ x :* y diff --git a/src/UVMHS/Core/Data/Lattice.hs b/src/UVMHS/Core/Data/Lattice.hs index cb180db2..d75f5b8a 100644 --- a/src/UVMHS/Core/Data/Lattice.hs +++ b/src/UVMHS/Core/Data/Lattice.hs @@ -6,41 +6,41 @@ import UVMHS.Core.Data.Arithmetic () -- The supplied function should be monotonic lfp ∷ (POrd a) ⇒ a → (a → a) → a -lfp i f = loop i +lfp i f = loop i where loop x = let x' = f x in case x' ⊑ x of - True → x + True → x False → loop x' lfpN ∷ (POrd a) ⇒ ℕ → a → (a → a) → a -lfpN n₀ i f = loop n₀ i +lfpN n₀ i f = loop n₀ i where loop n x | n ≡ 0 = x - | otherwise = + | otherwise = let x' = f x in case x' ⊑ x of - True → x + True → x False → loop (n - 1) x' -- The supplied function should be antitonic gfp ∷ (POrd a) ⇒ a → (a → a) → a -gfp i f = loop i +gfp i f = loop i where - loop x = + loop x = let x' = f x in case x ⊑ x' of True → x False → loop x' gfpN ∷ (POrd a) ⇒ ℕ → a → (a → a) → a -gfpN n₀ i f = loop n₀ i +gfpN n₀ i f = loop n₀ i where - loop n x + loop n x | n ≡ 0 = x - | otherwise = + | otherwise = let x' = f x in case x ⊑ x' of True → x diff --git a/src/UVMHS/Core/Data/Lens.hs b/src/UVMHS/Core/Data/Lens.hs index 69e780e1..be388b8b 100644 --- a/src/UVMHS/Core/Data/Lens.hs +++ b/src/UVMHS/Core/Data/Lens.hs @@ -135,9 +135,9 @@ keyL𝑂 k = class HasPrism a b where hasPrism ∷ a ⌲ b class HasLens a b where hasLens ∷ a ⟢ b -instance HasPrism a a where +instance HasPrism a a where hasPrism = refl -instance HasLens a a where +instance HasLens a a where hasLens = refl 𝛊 ∷ (HasPrism a b) ⇒ b → a @@ -151,4 +151,3 @@ instance HasLens a a where 𝛏 ∷ (HasLens a b) ⇒ b → a → a 𝛏 y x = snd (runLens hasLens x) y - diff --git a/src/UVMHS/Core/Data/List.hs b/src/UVMHS/Core/Data/List.hs index 102692d6..e186114b 100644 --- a/src/UVMHS/Core/Data/List.hs +++ b/src/UVMHS/Core/Data/List.hs @@ -4,23 +4,23 @@ import UVMHS.Core.Init import UVMHS.Core.Classes import UVMHS.Core.Data.LazyList () -instance Null (𝐿 a) where +instance Null (𝐿 a) where null = empty𝐿 -instance Append (𝐿 a) where +instance Append (𝐿 a) where (⧺) = append𝐿 instance Monoid (𝐿 a) -instance Functor 𝐿 where +instance Functor 𝐿 where map = map𝐿 instance Return 𝐿 where return = single𝐿 -instance Bind 𝐿 where +instance Bind 𝐿 where (≫=) = bind𝐿 instance Monad 𝐿 -instance FunctorM 𝐿 where +instance FunctorM 𝐿 where mapM = mapM𝐿 -instance Single a (𝐿 a) where +instance Single a (𝐿 a) where single = single𝐿 -instance ToIter a (𝐿 a) where +instance ToIter a (𝐿 a) where iter = iter𝐿 empty𝐿 ∷ 𝐿 a @@ -122,4 +122,3 @@ firstSome = \case Nil → None None :& xOs → firstSome xOs Some x :& _ → Some x - diff --git a/src/UVMHS/Core/Data/Option.hs b/src/UVMHS/Core/Data/Option.hs index cd05cb2a..182ce9dd 100644 --- a/src/UVMHS/Core/Data/Option.hs +++ b/src/UVMHS/Core/Data/Option.hs @@ -5,18 +5,18 @@ import UVMHS.Core.Classes import qualified Prelude as HS -instance Functor 𝑂 where +instance Functor 𝑂 where map = mmap -instance Return 𝑂 where +instance Return 𝑂 where return = Some -instance Bind 𝑂 where +instance Bind 𝑂 where xO ≫= k = case xO of {None → None;Some x → k x} instance Monad 𝑂 -instance FunctorM 𝑂 where +instance FunctorM 𝑂 where mapM f = \case None → return None Some x → Some ^$ f x -instance (Null a) ⇒ Null (𝑂 a) where +instance (Null a) ⇒ Null (𝑂 a) where null = Some null instance (Append a) ⇒ Append (𝑂 a) where None ⧺ _ = None diff --git a/src/UVMHS/Core/Data/Pair.hs b/src/UVMHS/Core/Data/Pair.hs index 0dbcefc6..4660d41b 100644 --- a/src/UVMHS/Core/Data/Pair.hs +++ b/src/UVMHS/Core/Data/Pair.hs @@ -5,39 +5,39 @@ import UVMHS.Core.Classes import UVMHS.Core.Data.Arithmetic () -instance (POrd a,POrd b) ⇒ POrd (a ∧ b) where +instance (POrd a,POrd b) ⇒ POrd (a ∧ b) where (x₁ :* y₁) ⊑ (x₂ :* y₂) = (x₁ ⊑ x₂) ⩓ (y₁ ⊑ y₂) -instance (Bot a,Bot b) ⇒ Bot (a ∧ b) where +instance (Bot a,Bot b) ⇒ Bot (a ∧ b) where bot = bot :* bot -instance (Join a,Join b) ⇒ Join (a ∧ b) where +instance (Join a,Join b) ⇒ Join (a ∧ b) where (a₁ :* b₁) ⊔ (a₂ :* b₂) = (a₁ ⊔ a₂) :* (b₁ ⊔ b₂) -instance (Top a,Top b) ⇒ Top (a ∧ b) where +instance (Top a,Top b) ⇒ Top (a ∧ b) where top = top :* top -instance (Meet a,Meet b) ⇒ Meet (a ∧ b) where +instance (Meet a,Meet b) ⇒ Meet (a ∧ b) where (a₁ :* b₁) ⊓ (a₂ :* b₂) = (a₁ ⊓ a₂) :* (b₁ ⊓ b₂) -instance (Dual a,Dual b) ⇒ Dual (a ∧ b) where +instance (Dual a,Dual b) ⇒ Dual (a ∧ b) where dual (a :* b) = dual a :* dual b -instance (Difference a,Difference b) ⇒ Difference (a ∧ b) where +instance (Difference a,Difference b) ⇒ Difference (a ∧ b) where (a₁ :* b₁) ⊟ (a₂ :* b₂) = (a₁ ⊟ a₂) :* (b₁ ⊟ b₂) instance (JoinLattice a,JoinLattice b) ⇒ JoinLattice (a ∧ b) instance (MeetLattice a,MeetLattice b) ⇒ MeetLattice (a ∧ b) instance (Lattice a,Lattice b) ⇒ Lattice (a ∧ b) -instance (Null a,Null b) ⇒ Null (a ∧ b) where +instance (Null a,Null b) ⇒ Null (a ∧ b) where null = (null :* null) -instance (Append a,Append b) ⇒ Append (a ∧ b) where +instance (Append a,Append b) ⇒ Append (a ∧ b) where (x₁ :* y₁) ⧺ (x₂ :* y₂) = (x₁ ⧺ x₂) :* (y₁ ⧺ y₂) instance (Monoid a,Monoid b) ⇒ Monoid (a ∧ b) -instance Functor ((∧) a) where +instance Functor ((∧) a) where map f (x :* y) = x :* f y -instance (Null a) ⇒ Return ((∧) a) where +instance (Null a) ⇒ Return ((∧) a) where return = (:*) null -instance (Append a) ⇒ Bind ((∧) a) where +instance (Append a) ⇒ Bind ((∧) a) where (a :* b) ≫= f = let (a' :* c) = f b in (a ⧺ a') :* c instance (Monoid a) ⇒ Monad ((∧) a) -instance FunctorM ((∧) a) where +instance FunctorM ((∧) a) where mapM f (x :* y) = map ((:*) x) $ f y fst ∷ a ∧ b → a @@ -75,4 +75,3 @@ mapMFst = flip mapMPair return mapMSnd ∷ (Monad m) ⇒ (b → m b') → a ∧ b → m (a ∧ b') mapMSnd = mapMPair return - diff --git a/src/UVMHS/Core/Data/Sequence.hs b/src/UVMHS/Core/Data/Sequence.hs index 39b1b9d1..db0237b3 100644 --- a/src/UVMHS/Core/Data/Sequence.hs +++ b/src/UVMHS/Core/Data/Sequence.hs @@ -11,26 +11,26 @@ import qualified Prelude as HS import qualified Data.Foldable as HS import qualified Data.Sequence as Sequence -instance Null (𝑄 a) where +instance Null (𝑄 a) where null = qø -instance Append (𝑄 a) where +instance Append (𝑄 a) where (⧺) = append𝑄 instance Monoid (𝑄 a) -instance Single a (𝑄 a) where +instance Single a (𝑄 a) where single = single𝑄 -instance Functor 𝑄 where +instance Functor 𝑄 where map = map𝑄 -instance Return 𝑄 where +instance Return 𝑄 where return = single -instance Bind 𝑄 where +instance Bind 𝑄 where (≫=) = bind𝑄 instance Monad 𝑄 -instance ToIter a (𝑄 a) where +instance ToIter a (𝑄 a) where iter = iter𝑄 -instance (Show a) ⇒ Show (𝑄 a) where +instance (Show a) ⇒ Show (𝑄 a) where show = tohsChars ∘ showCollection "[" "]" "," show𝕊 qø ∷ 𝑄 a diff --git a/src/UVMHS/Core/Data/Set.hs b/src/UVMHS/Core/Data/Set.hs index a7ab6d8e..3871e6b8 100644 --- a/src/UVMHS/Core/Data/Set.hs +++ b/src/UVMHS/Core/Data/Set.hs @@ -222,8 +222,8 @@ map𝑃 = coerce Set.map uniques𝑃 ∷ (Ord a,ToIter a t) ⇒ t → 𝐼 a uniques𝑃 xs = filterMap id $ appto (iter xs) $ reiter pø𝑃 $ \ x seen → - if x ∈♭ seen - then seen :* None + if x ∈♭ seen + then seen :* None else (single𝑃 x ∪♭ seen) :* Some x --------------- @@ -258,7 +258,7 @@ instance (Ord e) ⇒ Set e (𝑃 e) where psingle = psingle𝑃 padd = padd𝑃 prem = prem𝑃 - (∈) = (∈♭) + (∈) = (∈♭) (⊆) = (⊆♭) (∪) = (∪♭) (∩) = (∩♭) diff --git a/src/UVMHS/Core/Data/Stream.hs b/src/UVMHS/Core/Data/Stream.hs index 80652ffc..b2dbc0c0 100644 --- a/src/UVMHS/Core/Data/Stream.hs +++ b/src/UVMHS/Core/Data/Stream.hs @@ -15,7 +15,7 @@ eq𝑆 xs ys = case (un𝑆 xs (),un𝑆 ys ()) of (None,None) → True (None,Some _) → False (Some _,None) → False - (Some (x :* xs'),Some (y :* ys')) + (Some (x :* xs'),Some (y :* ys')) | x ≡ y → eq𝑆 xs' ys' | otherwise → False @@ -36,7 +36,7 @@ iter𝑆 ∷ 𝑆 a → 𝐼 a iter𝑆 xs₀ = 𝐼 HS.$ \ f → flip $ \ 𝓀 → let loop xs i = case un𝑆 xs () of None → 𝓀 i - Some (x :* xs') → + Some (x :* xs') → f x i $ \ i' → loop xs' i' in loop xs₀ @@ -47,43 +47,43 @@ zipWith𝑆 f = loop loop xs ys = 𝑆 $ \ () → case (un𝑆 xs (),un𝑆 ys ()) of (Some (x :* xs'),Some (y :* ys')) → Some (f x y :* loop xs' ys') _ → None - + -- import UVMHS.Core.Init -- import UVMHS.Core.Classes --- +-- -- import UVMHS.Core.Data.Arithmetic () -- import UVMHS.Core.Data.LazyList () -- import UVMHS.Core.Data.Iter -- import UVMHS.Core.Data.Option -- import UVMHS.Core.Data.Pair -- import UVMHS.Core.Data.String --- +-- -- instance (Eq a) ⇒ Eq (𝑆 a) where (==) = eqBy𝑆 (≡) -- instance (Ord a) ⇒ Ord (𝑆 a) where compare = compareBy𝑆 (⋚) -- instance (Show a) ⇒ Show (𝑆 a) where show = chars ∘ showWith𝑆 show𝕊 --- +-- -- instance Functor 𝑆 where map = map𝑆 --- +-- -- instance Null (𝑆 a) where null = empty𝑆 -- instance Append (𝑆 a) where (⧺) = append𝑆 -- instance Monoid (𝑆 a) --- +-- -- instance Return 𝑆 where return = single𝑆 -- instance Bind 𝑆 where (≫=) = bind𝑆 --- +-- -- instance Single a (𝑆 a) where single = single𝑆 --- +-- -- instance ToStream a (𝑆 a) where stream = id -- instance ToIter a (𝑆 a) where iter = iter𝑆 --- +-- -- empty𝑆 ∷ 𝑆 a -- empty𝑆 = 𝑆 () $ const None --- +-- -- single𝑆 ∷ a → 𝑆 a -- single𝑆 x = 𝑆 False $ \case -- False → Some $ x :* True -- True → None --- +-- -- append𝑆 ∷ 𝑆 a → 𝑆 a → 𝑆 a -- append𝑆 (𝑆 s₁₀ f₁) (𝑆 s₂₀ f₂) = 𝑆 (Inl s₁₀) $ \ s → -- let goLeft s₁ = case f₁ s₁ of @@ -95,13 +95,13 @@ zipWith𝑆 f = loop -- in case s of -- Inl s₁ → goLeft s₁ -- Inr s₂ → goRight s₂ --- +-- -- map𝑆 ∷ (a → b) → 𝑆 a → 𝑆 b --- map𝑆 f (𝑆 s₀ g) = 𝑆 s₀ $ \ s → +-- map𝑆 f (𝑆 s₀ g) = 𝑆 s₀ $ \ s → -- case g s of -- None → None -- Some (x:*s') → Some (f x:*s') --- +-- -- mjoin𝑆 ∷ ∀ a. 𝑆 (𝑆 a) → 𝑆 a -- mjoin𝑆 (𝑆 (s₀ ∷ s) (f ∷ s → 𝑂 (𝑆 a ∧ s))) = 𝑆 (𝑆 () (const None) :* s₀ ∷ 𝑆 a ∧ s) $ \ (𝑆 t g :* s) → loop₁ t g s -- where @@ -113,18 +113,18 @@ zipWith𝑆 f = loop -- loop₂ s = case f s of -- None → None -- Some (𝑆 t g :* s') → loop₁ t g s' --- +-- -- bind𝑆 ∷ 𝑆 a → (a → 𝑆 b) → 𝑆 b -- bind𝑆 xs k = mjoin𝑆 $ map𝑆 k xs --- +-- -- uncons𝑆 ∷ 𝑆 a → 𝑂 (a ∧ 𝑆 a) -- uncons𝑆 (𝑆 s g) = case g s of -- None → None -- Some (x :* s') → Some (x :* 𝑆 s' g) --- +-- -- uncons ∷ (ToStream a t) ⇒ t → 𝑂 (a ∧ 𝑆 a) -- uncons = uncons𝑆 ∘ stream --- +-- -- eqBy𝑆 ∷ (a → a → 𝔹) → 𝑆 a → 𝑆 a → 𝔹 -- eqBy𝑆 f (𝑆 s₁₀ g₁) (𝑆 s₂₀ g₂) = loop s₁₀ s₂₀ -- where @@ -133,9 +133,9 @@ zipWith𝑆 f = loop -- (Some _,None) → False -- (None,Some _) → False -- (Some (x₁ :* s₁'),Some (x₂ :* s₂')) → case f x₁ x₂ of --- True → loop s₁' s₂' +-- True → loop s₁' s₂' -- False → False --- +-- -- compareBy𝑆 ∷ (a → a → Ordering) → 𝑆 a → 𝑆 a → Ordering -- compareBy𝑆 f (𝑆 s₁₀ g₁) (𝑆 s₂₀ g₂) = loop s₁₀ s₂₀ -- where @@ -147,25 +147,25 @@ zipWith𝑆 f = loop -- LT → LT -- EQ → loop s₁' s₂' -- GT → GT --- +-- -- showWith𝑆 ∷ (a → 𝕊) → 𝑆 a → 𝕊 -- showWith𝑆 = showCollection "𝑆[" "]" "," --- +-- -- isEmpty ∷ (ToStream a t) ⇒ t → 𝔹 -- isEmpty (stream → 𝑆 s g) = isNone $ g s --- +-- -- naturals ∷ 𝑆 ℕ -- naturals = 𝑆 0 $ \ i → Some (i :* succ i) --- +-- -- zipWith :: (ToStream a t₁,ToStream b t₂) ⇒ (a → b → c) → t₁ → t₂ → 𝑆 c -- zipWith f (stream → 𝑆 s₁₀ g₁) (stream → 𝑆 s₂₀ g₂) = 𝑆 (s₁₀ :* s₂₀) $ \ (s₁ :* s₂) → do -- (x :* s₁') ← g₁ s₁ -- (y :* s₂') ← g₂ s₂ -- return $ f x y :* (s₁' :* s₂') --- +-- -- zip ∷ (ToStream a t₁,ToStream b t₂) ⇒ t₁ → t₂ → 𝑆 (a ∧ b) -- zip = zipWith (:*) --- +-- -- zip3With ∷ (ToStream a t₁,ToStream b t₂,ToStream c t₃) ⇒ (a → b → c → d) → t₁ → t₂ → t₃ → 𝑆 d -- zip3With f (stream → 𝑆 s₁₀ g₁) (stream → 𝑆 s₂₀ g₂) (stream → 𝑆 s₃₀ g₃) = -- 𝑆 (s₁₀ :* s₂₀ :* s₃₀) $ \ (s₁ :* s₂ :* s₃) → do @@ -173,29 +173,29 @@ zipWith𝑆 f = loop -- (y :* s₂') ← g₂ s₂ -- (z :* s₃') ← g₃ s₃ -- return $ f x y z :* (s₁' :* s₂' :* s₃') --- +-- -- zip3 ∷ (ToStream a t₁,ToStream b t₂,ToStream c t₃) ⇒ t₁ → t₂ → t₃ → 𝑆 (a ∧ b ∧ c) -- zip3 = zip3With $ (:*) ∘∘ (:*) --- +-- -- firstN ∷ (ToStream a t) ⇒ ℕ → t → 𝑆 a -- firstN n₀ (stream → 𝑆 s₀ g) = 𝑆 (s₀ :* 0) $ \ (s :* n) → case n ≡ n₀ of --- True → None +-- True → None -- False → do -- (x :* s') ← g s -- return (x :* (s' :* succ n)) --- +-- -- lastN ∷ (ToStream a t) ⇒ ℕ → t → 𝐼 a -- lastN n = reverse ∘ firstN n ∘ list ∘ reverse ∘ stream --- +-- -- skipN ∷ (ToStream a t) ⇒ ℕ → t → 𝑆 a -- skipN n₀ (stream → 𝑆 s₀ g) = 𝑆 (loop 0 s₀) g -- where --- loop n s --- | n ≡ n₀ = s +-- loop n s +-- | n ≡ n₀ = s -- | otherwise = ifNone s $ do -- s' ← snd ^$ g s -- return $ loop (succ n) s' --- +-- -- stripPrefix𝑆 ∷ (Eq a,ToStream a t₁,ToStream a t₂) ⇒ t₁ → t₂ → 𝑂 (𝑆 a) -- stripPrefix𝑆 (stream → 𝑆 s₁₀ g₁) (stream → 𝑆 s₂₀ g₂) = loop s₁₀ s₂₀ -- where @@ -204,35 +204,35 @@ zipWith𝑆 f = loop -- Some (x :* s₁') → do -- (y :* s₂') ← g₂ s₂ -- case x ≡ y of --- True → loop s₁' s₂' +-- True → loop s₁' s₂' -- False → None --- +-- -- prefixBefore𝑆 ∷ (ToStream a t) ⇒ (a → 𝔹) → t → 𝑆 a -- prefixBefore𝑆 p (stream → 𝑆 s₀ g) = 𝑆 s₀ $ \ s → do -- (x :* s') ← g s -- case p x of --- True → None +-- True → None -- False → Some (x :* s') --- +-- -- prefixBeforeN𝑆 ∷ (ToStream a t) ⇒ ℕ → (a → ℕ) → t → 𝑆 a --- prefixBeforeN𝑆 n₀ p (stream → 𝑆 s₀ g) +-- prefixBeforeN𝑆 n₀ p (stream → 𝑆 s₀ g) -- | n₀ ≡ 0 = empty𝑆 -- | otherwise = 𝑆 (0 :* s₀) $ \ (n :* s) → do -- (x :* s') ← g s -- let n' = n + p x -- case n' ≥ n₀ of --- True → None +-- True → None -- False → return (x :* (n' :* s')) --- +-- -- postfixAfter𝑆 ∷ (ToStream a t) ⇒ (a → 𝔹) → t → 𝑆 a -- postfixAfter𝑆 p (stream → 𝑆 s₀ g) = ifNone empty𝑆 $ loop s₀ -- where -- loop s = do -- (x :* s') ← g s -- case p x of --- True → Some (𝑆 s' g) +-- True → Some (𝑆 s' g) -- False → loop s' --- +-- -- inbetween𝑆 ∷ (ToStream a t) ⇒ a → t → 𝑆 a -- inbetween𝑆 i (stream → 𝑆 s₀ g) = 𝑆 (s₀ :* None) $ \ (s :* xMM) → do -- case xMM of @@ -244,15 +244,15 @@ zipWith𝑆 f = loop -- return $ i :* (s' :* Some (Some x)) -- Some (Some x) → do -- return $ x :* (s :* Some None) --- +-- -- coredata_stream_e1 ∷ 𝑆 ℕ -- coredata_stream_e1 = stream [1,2,3,4,5,4,3,2,1] --- +-- -- filter𝑆 ∷ (ToStream a t) ⇒ (a → 𝔹) → t → 𝑆 a -- filter𝑆 f (stream → 𝑆 s₀ g) = 𝑆 s₀ loop -- where -- loop s = do -- (x :* s') ← g s --- if f x +-- if f x -- then Some $ x :* s' -- else loop s' diff --git a/src/UVMHS/Core/Data/String.hs b/src/UVMHS/Core/Data/String.hs index 3866cd5c..911c775b 100644 --- a/src/UVMHS/Core/Data/String.hs +++ b/src/UVMHS/Core/Data/String.hs @@ -11,16 +11,16 @@ import qualified Data.Text.Lazy as TextLazy import qualified Data.Text.Lazy.Builder as TextBuilder import qualified Prelude as HS -instance Null 𝕊 where +instance Null 𝕊 where null = Text.empty -instance Append 𝕊 where +instance Append 𝕊 where (⧺) = Text.append instance Monoid 𝕊 -instance Single ℂ 𝕊 where +instance Single ℂ 𝕊 where single = Text.singleton -instance ToIter ℂ 𝕊 where +instance ToIter ℂ 𝕊 where iter cs = 𝐼 HS.$ \ f → flip $ \ 𝓀 → case TextI.stream cs of TextI.Stream g s₀ _ → @@ -32,8 +32,8 @@ instance ToIter ℂ 𝕊 where loop s' i' in loop s₀ -instance Lookup ℕ ℂ 𝕊 where - s ⋕? n +instance Lookup ℕ ℂ 𝕊 where + s ⋕? n | (n > 0) ⩓ (n ≤ length𝕊 s) = Some $ Text.index s $ HS.fromIntegral $ n - 1 | otherwise = None diff --git a/src/UVMHS/Core/Effects.hs b/src/UVMHS/Core/Effects.hs index 8f391760..852b5944 100644 --- a/src/UVMHS/Core/Effects.hs +++ b/src/UVMHS/Core/Effects.hs @@ -74,31 +74,31 @@ class LiftTop t where liftMtop ∷ ∀ m. (Monad m) ⇒ (∀ a. m a) → (∀ a. t m a) class MonadCont r m | m → r where - callCC ∷ ∀ a. ((a → m r) → m r) → m a - withC ∷ ∀ a. (a → m r) → m a → m r + callCC ∷ ∀ a. ((a → m r) → m r) → m a + withC ∷ ∀ a. (a → m r) → m a → m r class LiftCont t where - liftCallCC ∷ - ∀ m r. (Monad m) - ⇒ (∀ a. ((a → m r) → m r) → m a) + liftCallCC ∷ + ∀ m r. (Monad m) + ⇒ (∀ a. ((a → m r) → m r) → m a) → (∀ a. ((a → t m r) → t m r) → t m a) - liftWithC ∷ - ∀ m r. (Monad m) - ⇒ (∀ a. (a → m r) → m a → m r) + liftWithC ∷ + ∀ m r. (Monad m) + ⇒ (∀ a. (a → m r) → m a → m r) → (∀ a. (a → t m r) → t m a → t m r) class MonadUCont m where - ucallCC ∷ ∀ a. (∀ u. (a → m u) → m u) → m a - uwithC ∷ ∀ a u. (a → m u) → m a → m u + ucallCC ∷ ∀ a. (∀ u. (a → m u) → m u) → m a + uwithC ∷ ∀ a u. (a → m u) → m a → m u class LiftUCont t where - liftUCallCC ∷ - ∀ m. (Monad m) - ⇒ (∀ a. (∀ u. (a → m u) → m u) → m a) + liftUCallCC ∷ + ∀ m. (Monad m) + ⇒ (∀ a. (∀ u. (a → m u) → m u) → m a) → (∀ a. (∀ u. (a → t m u) → t m u) → t m a) - liftUWithC ∷ - ∀ m. (Monad m) - ⇒ (∀ a u. (a → m u) → m a → m u) + liftUWithC ∷ + ∀ m. (Monad m) + ⇒ (∀ a u. (a → m u) → m a → m u) → (∀ a u. (a → t m u) → t m a → t m u) class MonadBad m where @@ -176,7 +176,7 @@ ask = askL refl local ∷ (Monad m,MonadReader r m) ⇒ r → m a → m a local = localL refl -mapEnv ∷ (Monad m,MonadReader r m) ⇒ (r → r) → m a → m a +mapEnv ∷ (Monad m,MonadReader r m) ⇒ (r → r) → m a → m a mapEnv = mapEnvL refl -- Writer @@ -203,26 +203,26 @@ retOut xM = do -- # State -getL ∷ (Monad m,MonadState s m) ⇒ s ⟢ a → m a +getL ∷ (Monad m,MonadState s m) ⇒ s ⟢ a → m a getL l = map (access l) get -putL ∷ (Monad m,MonadState s m) ⇒ s ⟢ a → a → m () +putL ∷ (Monad m,MonadState s m) ⇒ s ⟢ a → a → m () putL 𝓁 = modify ∘ update 𝓁 -modify ∷ (Monad m,MonadState s m) ⇒ (s → s) → m () +modify ∷ (Monad m,MonadState s m) ⇒ (s → s) → m () modify f = do s ← get put $ f s -modifyM ∷ (Monad m,MonadState s m) ⇒ (s → m s) → m () +modifyM ∷ (Monad m,MonadState s m) ⇒ (s → m s) → m () modifyM f = do s ← get put *$ f s -modifyL ∷ (Monad m,MonadState s m) ⇒ s ⟢ a → (a → a) → m () +modifyL ∷ (Monad m,MonadState s m) ⇒ s ⟢ a → (a → a) → m () modifyL 𝓁 = modify ∘ alter 𝓁 -modifyML ∷ (Monad m,MonadState s m) ⇒ s ⟢ a → (a → m a) → m () +modifyML ∷ (Monad m,MonadState s m) ⇒ s ⟢ a → (a → m a) → m () modifyML 𝓁 = modifyM ∘ alterM 𝓁 getput ∷ (Monad m,MonadState s m) ⇒ s → m s @@ -349,7 +349,7 @@ throwEff = extend $ elimChoice throw return throwObs ∷ (Monad m,MonadError e m) ⇒ m a → m (e ∨ a) throwObs xM = catch (map Inr xM) $ return ∘ Inl -throw𝑂 ∷ (Monad m,MonadError e m) ⇒ e → 𝑂 a → m a +throw𝑂 ∷ (Monad m,MonadError e m) ⇒ e → 𝑂 a → m a throw𝑂 e = elim𝑂 (const $ throw e) return -- Nondet -- @@ -410,7 +410,7 @@ return𝑃 = fold mzero (\ x xM → xM ⊞ return x) -- Cont -- -reset ∷ (Monad m,MonadCont u m) ⇒ m u → m u +reset ∷ (Monad m,MonadCont u m) ⇒ m u → m u reset aM = callCC $ \ k → k *$ withC return aM modifyC ∷ (Monad m,MonadCont u m) ⇒ (u → m u) → m () @@ -437,7 +437,7 @@ modifyEnvL ℓ f = do -- UCont -- -ureset ∷ (Monad m,MonadUCont m) ⇒ m a → m a +ureset ∷ (Monad m,MonadUCont m) ⇒ m a → m a ureset aM = ucallCC HS.$ \ k → k *$ uwithC return aM umodifyC ∷ (Monad m,MonadUCont m) ⇒ (∀ u. u → m u) → m () diff --git a/src/UVMHS/Core/IO.hs b/src/UVMHS/Core/IO.hs index 69d4aa45..9363dd85 100644 --- a/src/UVMHS/Core/IO.hs +++ b/src/UVMHS/Core/IO.hs @@ -1,5 +1,5 @@ module UVMHS.Core.IO - ( module UVMHS.Core.IO + ( module UVMHS.Core.IO , module System.IO.Error , module System.Exit ) where @@ -92,7 +92,7 @@ trace s = io_UNSAFE $ do traceM ∷ (Monad m) ⇒ 𝕊 → m () traceM msg = - let _ = trace msg + let _ = trace msg in skip ------------------ @@ -282,14 +282,13 @@ profile xM = do u₁ = Stat.cumulative_live_bytes s₁ -- total CPU time at previous GC in nanoseconds t₁ = Stat.cpu_ns s₁ - -- + -- n₂ = Stat.major_gcs s₂ u₂ = Stat.cumulative_live_bytes s₂ t₂ = Stat.cpu_ns s₂ -- -- elapsed CPU time in seconds - t' = dbl (t₂ - t₁) / 1000000000.0 + t' = dbl (t₂ - t₁) / 1000000000.0 -- average live data across GCs m = dbl (u₂ - u₁) / dbl (n₂ - n₁) return $ x :* t' :* m - diff --git a/src/UVMHS/Core/Init.hs b/src/UVMHS/Core/Init.hs index 8a0d3f6f..e7daaa27 100644 --- a/src/UVMHS/Core/Init.hs +++ b/src/UVMHS/Core/Init.hs @@ -13,14 +13,14 @@ import Prelude , Bool(..),Eq((==)),Ord(compare),Show(show),Ordering(..),IO , fromInteger ) -import Data.Coerce +import Data.Coerce ( coerce , Coercible ) -import GHC.Exts +import GHC.Exts ( type Constraint ) -import GHC.Stack +import GHC.Stack ( type CallStack,callStack,withFrozenCallStack ) @@ -137,7 +137,7 @@ data 𝑂 a = None | Some a data 𝐿 a = Nil | a :& 𝐿 a deriving (Eq,Ord,TH.Lift) --- iterator type +-- iterator type -- fold function continuation -- ↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ ↓↓↓↓↓↓↓ newtype 𝐼 a = 𝐼 { un𝐼 ∷ ∀ b. (a → b → (b → b) → b) → b → (b → b) → b } @@ -194,7 +194,7 @@ iterLL ∷ [a] → 𝐼 a iterLL xs₀ = 𝐼 HS.$ \ f → flip $ \ 𝓀 → let loop xs i = case xs of [] → 𝓀 i - x:xs' → + x:xs' → f x i $ \ i' → loop xs' i' in loop xs₀ @@ -417,7 +417,7 @@ class CHS a b | b → a where tohs ∷ a → b frhs ∷ b → a -instance {-# OVERLAPPABLE #-} (a ~ b) ⇒ CHS a b where +instance {-# OVERLAPPABLE #-} (a ~ b) ⇒ CHS a b where tohs = id frhs = id instance {-# OVERLAPPING #-} CHS ℤ64 HS.Int where diff --git a/src/UVMHS/Core/LensDeriving.hs b/src/UVMHS/Core/LensDeriving.hs index 051cf7cf..a601f041 100644 --- a/src/UVMHS/Core/LensDeriving.hs +++ b/src/UVMHS/Core/LensDeriving.hs @@ -10,7 +10,7 @@ import UVMHS.Core.TH import qualified Language.Haskell.TH as TH --- makeLensLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] field fieldty ≔ +-- makeLensLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] field fieldty ≔ -- [| fieldL ∷ ∀ a₁ … aₙ. (C₁,…,Cₙ) ⇒ ty a₁ … aₙ ⟢ fieldty -- fieldL ≔ lens field (\ x s → s { field = x }) -- |] @@ -25,10 +25,10 @@ makeLensLogic cx ty tyargs field fieldty = do tmpˢ ← TH.newName $ tohsChars "s" return $ list [ TH.PragmaD $ TH.InlineP lensName TH.Inline TH.FunLike TH.AllPhases - , TH.SigD lensName $ + , TH.SigD lensName $ TH.ForallT (tohs tyargs') cx $ TH.ConT ''(⟢) ⊙ (TH.ConT ty ⊙⋆ tyargVars) ⊙ fieldty - , TH.FunD lensName $ single $ thSingleClause null $ + , TH.FunD lensName $ single $ thSingleClause null $ TH.VarE 'lens ⊙ TH.VarE field ⊙$ TH.LamE [TH.VarP tmpˢ,TH.VarP tmpˣ] $ TH.RecUpdE (TH.VarE tmpˢ) [(field,TH.VarE tmpˣ)] ] @@ -38,9 +38,9 @@ makeLenses name = do (_ :* fields) ← ifNoneM (io abortIO) $ view thRecCL c map (tohs ∘ concat) $ mapMOn fields $ \ (frhs → (field :* _ :* fieldty)) → makeLensLogic cx ty tyargs field fieldty --- makePrismLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] con (fieldty₁,…,fieldtyₙ) ≔ +-- makePrismLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] con (fieldty₁,…,fieldtyₙ) ≔ -- [| fieldL ∷ ∀ a₁ … aₙ. (C₁,…,Cₙ) ⇒ ty a₁ … aₙ ⌲ (fieldty₁,…,fieldtyₙ) --- fieldL ≔ Prism +-- fieldL ≔ Prism -- { inject = con -- , view = \ v → case v of -- con x₁ … xₙ → Some (x₁,…,xₙ) @@ -59,15 +59,15 @@ makePrismLogic cx ty tyargs con fieldtys numcons = do return $ list [ TH.PragmaD $ TH.InlineP prismName TH.Inline TH.FunLike TH.AllPhases - , TH.SigD prismName $ - TH.ForallT (tohs tyargs') cx $ + , TH.SigD prismName $ + TH.ForallT (tohs tyargs') cx $ TH.ConT ''(⌲) ⊙ (TH.ConT ty ⊙⋆ tyargVars) ⊙ tup fieldtys - , TH.FunD prismName $ single $ thSingleClause null $ - TH.ConE 'Prism + , TH.FunD prismName $ single $ thSingleClause null $ + TH.ConE 'Prism ⊙ (TH.LamE [tup $ map TH.VarP tmpˣˢ] $ TH.ConE con ⊙⋆ map TH.VarE tmpˣˢ) - ⊙ (TH.LamE [TH.VarP tmpˣ] $ + ⊙ (TH.LamE [TH.VarP tmpˣ] $ TH.CaseE (TH.VarE tmpˣ) $ concat - [ single $ thSingleMatch (TH.ConP con [] $ tohs (map TH.VarP tmpˣˢ)) $ + [ single $ thSingleMatch (TH.ConP con [] $ tohs (map TH.VarP tmpˣˢ)) $ TH.ConE 'Some ⊙ tup (map TH.VarE tmpˣˢ) , case numcons ≤ 1 of -- avoids generating code that has a dead branch @@ -82,4 +82,3 @@ makePrisms name = do scs ← mapM (ifNoneM (io abortIO) ∘ thViewSimpleCon) cs let numcons = count scs map (tohs ∘ concat) $ mapMOn scs $ \ (con :* fieldtys) → makePrismLogic cx ty tyargs con fieldtys numcons - diff --git a/src/UVMHS/Core/Monads.hs b/src/UVMHS/Core/Monads.hs index 91edc6e0..4e8a1098 100644 --- a/src/UVMHS/Core/Monads.hs +++ b/src/UVMHS/Core/Monads.hs @@ -14,26 +14,26 @@ instance (Return m) ⇒ Null (MU m) where null = MU $ return () instance (Bind m) ⇒ Append (MU m) where x ⧺ y = MU $ unMU x ≫ unMU y instance (Monad m) ⇒ Monoid (MU m) -instance MonadIO IO where +instance MonadIO IO where io = id -instance Functor IO where +instance Functor IO where map = mmap -instance Return IO where +instance Return IO where return = HS.return -instance Bind IO where +instance Bind IO where (≫=) = (HS.>>=) instance Monad IO newtype ID a = ID { unID ∷ a } - deriving + deriving ( Null,Append,Monoid , Bot,Join,JoinLattice , Top,Meet,MeetLattice , Lattice,Dual,Difference ) -instance Functor ID where +instance Functor ID where map = mmap instance Return ID where return ∷ ∀ a. a → ID a @@ -60,7 +60,7 @@ newtype ReaderT r m a = ReaderT { unReaderT ∷ r → m a } runReaderT ∷ ∀ r m a. r → ReaderT r m a → m a runReaderT r xM = unReaderT xM r -instance (Functor m) ⇒ Functor (ReaderT r m) where +instance (Functor m) ⇒ Functor (ReaderT r m) where map ∷ ∀ a b. (a → b) → ReaderT r m a → ReaderT r m b map f = ReaderT ∘ map (map f) ∘ unReaderT instance (Return m) ⇒ Return (ReaderT r m) where @@ -90,7 +90,7 @@ instance (Func Null m,Null a) ⇒ Null (ReaderT r m a) where instance (Func Append m,Append a) ⇒ Append (ReaderT r m a) where (⧺) ∷ ReaderT r m a → ReaderT r m a → ReaderT r m a (⧺) xM₁ xM₂ = ReaderT $ \ r → unReaderT xM₁ r ⧺ unReaderT xM₂ r -instance +instance ( Func Null m , Func Append m , Monoid a @@ -109,7 +109,7 @@ newtype WriterT o m a = WriterT { unWriterT ∷ m (o ∧ a) } evalWriterT ∷ ∀ o m a. (Functor m) ⇒ WriterT o m a → m a evalWriterT = map snd ∘ unWriterT -instance (Functor m) ⇒ Functor (WriterT o m) where +instance (Functor m) ⇒ Functor (WriterT o m) where map ∷ ∀ a b. (a → b) → WriterT o m a → WriterT o m b map f = WriterT ∘ map (map f) ∘ unWriterT @@ -143,12 +143,12 @@ instance (Func Null m,Null o,Null a) ⇒ Null (WriterT o m a) where instance (Func Append m,Append o,Append a) ⇒ Append (WriterT o m a) where (⧺) ∷ WriterT o m a → WriterT o m a → WriterT o m a xM₁ ⧺ xM₂ = WriterT $ unWriterT xM₁ ⧺ unWriterT xM₂ -instance +instance ( Func Null m , Func Append m , Monoid o , Monoid a - ) + ) ⇒ Monoid (WriterT o m a) instance (Null o) ⇒ Transformer (WriterT o) where @@ -167,7 +167,7 @@ runStateT s xM = unStateT xM s evalStateT ∷ ∀ s m a. (Functor m) ⇒ s → StateT s m a → m a evalStateT s = map snd ∘ runStateT s -instance (Functor m) ⇒ Functor (StateT s m) where +instance (Functor m) ⇒ Functor (StateT s m) where map ∷ ∀ a b. (a → b) → StateT s m a → StateT s m b map f = StateT ∘ map (map (map f)) ∘ unStateT @@ -188,7 +188,7 @@ instance Functor2 (StateT s) where instance (Return m) ⇒ MonadState s (StateT s m) where get ∷ StateT s m s get = StateT $ \ s → return (s :* s) - + put ∷ s → StateT s m () put s = StateT $ \ _ → return (s :* ()) @@ -198,11 +198,11 @@ instance (Func Null m,Null s,Null a) ⇒ Null (StateT s m a) where instance (Func Append m,Append s,Append a) ⇒ Append (StateT s m a) where (⧺) ∷ StateT s m a → StateT s m a → StateT s m a xM₁ ⧺ xM₂ = StateT $ \ s → unStateT xM₁ s ⧺ unStateT xM₂ s -instance +instance ( Func Null m , Func Append m , Monoid s,Monoid a - ) + ) ⇒ Monoid (StateT s m a) type State s = StateT s ID @@ -226,7 +226,7 @@ instance Transformer (StateT s) where newtype FailT m a = FailT { unFailT ∷ m (𝑂 a) } -instance (Functor m) ⇒ Functor (FailT m) where +instance (Functor m) ⇒ Functor (FailT m) where map ∷ ∀ a b. (a → b) → FailT m a → FailT m b map f = FailT ∘ map (map f) ∘ unFailT @@ -243,7 +243,7 @@ instance (Monad m) ⇒ Bind (FailT m) where instance (Monad m) ⇒ Monad (FailT m) instance Functor2 FailT where - map2 ∷ ∀ m₁ m₂. (∀ a. m₁ a → m₂ a) → (∀ a. FailT m₁ a → FailT m₂ a) + map2 ∷ ∀ m₁ m₂. (∀ a. m₁ a → m₂ a) → (∀ a. FailT m₁ a → FailT m₂ a) map2 f = FailT ∘ f ∘ unFailT instance (Monad m) ⇒ MonadFail (FailT m) where @@ -263,11 +263,11 @@ instance (Func Null m,Null a) ⇒ Null (FailT m a) where instance (Func Append m,Append a) ⇒ Append (FailT m a) where (⧺) ∷ FailT m a → FailT m a → FailT m a xM₁ ⧺ xM₂ = FailT $ unFailT xM₁ ⧺ unFailT xM₂ -instance +instance ( Func Null m , Func Append m , Monoid a - ) + ) ⇒ Monoid (FailT m a) instance Transformer FailT where @@ -317,7 +317,7 @@ instance (Func Null m,Null a) ⇒ Null (ErrorT e m a) where instance (Func Append m,Append e,Append a) ⇒ Append (ErrorT e m a) where (⧺) ∷ ErrorT e m a → ErrorT e m a → ErrorT e m a xM₁ ⧺ xM₂ = ErrorT $ unErrorT xM₁ ⧺ unErrorT xM₂ -instance +instance ( Func Null m , Func Append m , Append e,Monoid a @@ -349,9 +349,9 @@ instance Functor2 DelayT where instance MonadDelay (DelayT m) where delay xMU = DelayT $ \ () → runDelayT $ xMU () -instance (Const Null m) ⇒ Null (DelayT m a) where +instance (Const Null m) ⇒ Null (DelayT m a) where null = DelayT $ \ () → null -instance (Const Append m) ⇒ Append (DelayT m a) where +instance (Const Append m) ⇒ Append (DelayT m a) where xM₁ ⧺ xM₂ = DelayT $ \ () → runDelayT xM₁ ⧺ runDelayT xM₂ instance (Const Null m,Const Append m) ⇒ Monoid (DelayT m a) @@ -363,14 +363,14 @@ instance Transformer DelayT where lift xM = DelayT $ \ () → xM newtype NondetT m a = NondetT { unNondetT ∷ m (𝑄 a) } -instance (Functor m) ⇒ Functor (NondetT m) where +instance (Functor m) ⇒ Functor (NondetT m) where map ∷ ∀ a b. (a → b) → NondetT m a → NondetT m b map f xM = NondetT $ map (map f) $ unNondetT xM instance (Return m) ⇒ Return (NondetT m) where return ∷ ∀ a. a → NondetT m a return x = NondetT $ return $ single x -instance (Bind m,Func Monoid m) ⇒ Bind (NondetT m) where +instance (Bind m,Func Monoid m) ⇒ Bind (NondetT m) where (≫=) ∷ ∀ a b. NondetT m a → (a → NondetT m b) → NondetT m b xM ≫= k = NondetT $ do xs ← unNondetT xM @@ -414,20 +414,20 @@ instance Monad (ContT u m) instance Functor2Iso (ContT u) where map2iso ∷ ∀ m₁ m₂. Iso2 m₁ m₂ → ∀ a. ContT u m₁ a → ContT u m₂ a - map2iso i xM = ContT $ \ (k ∷ a → m₂ r) → - ito2 i $ unContT xM $ \ (x ∷ a) → + map2iso i xM = ContT $ \ (k ∷ a → m₂ r) → + ito2 i $ unContT xM $ \ (x ∷ a) → ifr2 i $ k x instance (Monad m) ⇒ MonadCont u (ContT u m) where callCC ∷ ∀ a. ((a → ContT u m u) → ContT u m u) → ContT u m a - callCC kk = ContT $ \ (k ∷ a → m r) → - runContT return $ kk $ \ (x ∷ a) → - ContT $ \ (k' ∷ r → m r) → + callCC kk = ContT $ \ (k ∷ a → m r) → + runContT return $ kk $ \ (x ∷ a) → + ContT $ \ (k' ∷ r → m r) → k' *$ k x withC ∷ ∀ a. (a → ContT u m u) → ContT u m a → ContT u m u withC k₁ xM = ContT $ \ (k₂ ∷ u → m u) → - k₂ *$ unContT xM $ \ (x ∷ a) → + k₂ *$ unContT xM $ \ (x ∷ a) → runContT return $ k₁ x instance (Func Null m,Null u) ⇒ Null (ContT u m a) where @@ -436,11 +436,11 @@ instance (Func Null m,Null u) ⇒ Null (ContT u m a) where instance (Func Append m,Append u) ⇒ Append (ContT u m a) where (⧺) ∷ ContT u m a → ContT u m a → ContT u m a xM₁ ⧺ xM₂ = ContT $ \ (k ∷ a → m r) → unContT xM₁ k ⧺ unContT xM₂ k -instance +instance ( Func Null m , Func Append m , Monoid u - ) + ) ⇒ Monoid (ContT u m a) instance Transformer (ContT u) where @@ -473,20 +473,20 @@ instance Monad (UContT m) instance Functor2Iso UContT where map2iso ∷ ∀ m₁ m₂. Iso2 m₁ m₂ → ∀ a. UContT m₁ a → UContT m₂ a - map2iso i xM = UContT HS.$ \ (k ∷ a → m₂ u) → - ito2 i $ unUContT xM $ \ (x ∷ a) → + map2iso i xM = UContT HS.$ \ (k ∷ a → m₂ u) → + ito2 i $ unUContT xM $ \ (x ∷ a) → ifr2 i $ k x instance (Monad m) ⇒ MonadUCont (UContT m) where ucallCC ∷ ∀ a. (∀ u. (a → UContT m u) → UContT m u) → UContT m a - ucallCC ff = UContT HS.$ \ (𝓀 ∷ a → m u₁) → - evalUContT $ ff $ \ (x ∷ a) → - UContT HS.$ \ (𝓀' ∷ u₁ → m u₂) → + ucallCC ff = UContT HS.$ \ (𝓀 ∷ a → m u₁) → + evalUContT $ ff $ \ (x ∷ a) → + UContT HS.$ \ (𝓀' ∷ u₁ → m u₂) → 𝓀' *$ 𝓀 x uwithC ∷ ∀ a u. (a → UContT m u) → UContT m a → UContT m u uwithC f xM = UContT HS.$ \ (𝓀 ∷ u → m u₁) → - 𝓀 *$ unUContT xM $ \ (x ∷ a) → + 𝓀 *$ unUContT xM $ \ (x ∷ a) → evalUContT $ f x instance (Const Null m) ⇒ Null (UContT m a) where @@ -495,7 +495,7 @@ instance (Const Null m) ⇒ Null (UContT m a) where instance (Const Append m) ⇒ Append (UContT m a) where (⧺) ∷ UContT m a → UContT m a → UContT m a xM₁ ⧺ xM₂ = UContT HS.$ \ (𝓀 ∷ a → m u) → unUContT xM₁ 𝓀 ⧺ unUContT xM₂ 𝓀 -instance +instance ( Const Monoid m ) ⇒ Monoid (UContT m a) @@ -514,7 +514,7 @@ instance Transformer UContT where instance LiftIO (ReaderT r) where liftIO ∷ ∀ m. (Monad m) ⇒ (∀ a. IO a → m a) → (∀ a. IO a → ReaderT r m a) liftIO ioM xM = ReaderT $ \ _ → ioM xM -instance (Monad m,MonadIO m) ⇒ MonadIO (ReaderT r m) where +instance (Monad m,MonadIO m) ⇒ MonadIO (ReaderT r m) where io = liftIO io instance LiftReader (ReaderT r) where @@ -530,7 +530,7 @@ instance LiftWriter (ReaderT r) where liftHijack ∷ ∀ m o. (Monad m) ⇒ (∀ a. m a → m (o ∧ a)) → (∀ a. ReaderT r m a → ReaderT r m (o ∧ a)) liftHijack hijackM xM = ReaderT $ \ r → hijackM $ unReaderT xM r -instance (Monad m,MonadWriter o m) ⇒ MonadWriter o (ReaderT r m) where +instance (Monad m,MonadWriter o m) ⇒ MonadWriter o (ReaderT r m) where tell = liftTell tell hijack = liftHijack hijack @@ -578,7 +578,7 @@ instance LiftNondet (ReaderT r) where instance (Monad m,MonadNondet m) ⇒ MonadNondet (ReaderT r m) where mzero = liftMzero mzero (⊞) = liftMplus (⊞) - + instance LiftTop (ReaderT r) where liftMtop ∷ ∀ m. (Monad m) ⇒ (∀ a. m a) → (∀ a. ReaderT r m a) liftMtop mtopM = ReaderT $ \ _ → mtopM @@ -587,10 +587,10 @@ instance (Monad m,MonadTop m) ⇒ MonadTop (ReaderT r m) where instance LiftCont (ReaderT r) where liftCallCC ∷ ∀ m r'. (Monad m) ⇒ (∀ a. ((a → m r') → m r') → m a) → (∀ a. ((a → ReaderT r m r') → ReaderT r m r') → ReaderT r m a) - liftCallCC callCCM kk = ReaderT $ \ r → - callCCM $ \ (k ∷ a → m r') → - runReaderT r $ kk $ \ (x ∷ a) → - ReaderT $ \ _ → + liftCallCC callCCM kk = ReaderT $ \ r → + callCCM $ \ (k ∷ a → m r') → + runReaderT r $ kk $ \ (x ∷ a) → + ReaderT $ \ _ → k x liftWithC ∷ ∀ m r'. (Monad m) ⇒ (∀ a. (a → m r') → m a → m r') → (∀ a. (a → ReaderT r m r') → ReaderT r m a → ReaderT r m r') liftWithC withCM k xM = ReaderT $ \ r → @@ -622,7 +622,7 @@ instance (Null o) ⇒ LiftReader (WriterT o) where instance (Null o,Monad m,MonadReader r m) ⇒ MonadReader r (WriterT o m) where askL = liftAskL askL localL = liftLocalL localL - + instance (Null o) ⇒ LiftWriter (WriterT o) where liftTell ∷ ∀ m o'. (Monad m) ⇒ (o' → m ()) → (o' → WriterT o m ()) liftTell tellM o' = WriterT $ do @@ -692,12 +692,12 @@ instance (Monad m,MonadTop m) ⇒ MonadTop (WriterT o m) where instance (Monoid o,Monad m,MonadCont (o ∧ r) m) ⇒ MonadCont r (WriterT o m) where callCC ∷ ∀ a. ((a → WriterT o m r) → WriterT o m r) → WriterT o m a callCC kk = WriterT $ callCC $ \ (k ∷ (o ∧ a) → m (o ∧ r)) → - unWriterT $ kk $ \ (x ∷ a) → + unWriterT $ kk $ \ (x ∷ a) → WriterT $ k $ null :* x withC ∷ ∀ a. (a → WriterT o m r) → WriterT o m a → WriterT o m r - withC k xM = WriterT $ - withCOn (unWriterT xM) $ \ (o₁ :* x ∷ o ∧ a) → do + withC k xM = WriterT $ + withCOn (unWriterT xM) $ \ (o₁ :* x ∷ o ∧ a) → do o₂ :* r ← unWriterT $ k x return $ (o₁ ⧺ o₂) :* r @@ -793,15 +793,15 @@ instance (Monad m,MonadTop m) ⇒ MonadTop (StateT s m) where instance (Monad m,MonadCont (s ∧ u) m) ⇒ MonadCont u (StateT s m) where callCC ∷ ∀ a. ((a → StateT s m u) → StateT s m u) → StateT s m a - callCC ff = StateT $ \ s₁ → + callCC ff = StateT $ \ s₁ → callCC $ \ (𝓀 ∷ (s ∧ a) → m (s ∧ u)) → - runStateT s₁ $ ff $ \ (x ∷ a) → + runStateT s₁ $ ff $ \ (x ∷ a) → StateT $ \ s₂ → 𝓀 $ s₂ :* x withC ∷ ∀ a. (a → StateT s m u) → StateT s m a → StateT s m u withC f xM = StateT $ \ s₁ → - withCOn (runStateT s₁ xM) $ \ (s₂ :* x ∷ s ∧ a) → + withCOn (runStateT s₁ xM) $ \ (s₂ :* x ∷ s ∧ a) → runStateT s₂ $ f x ---------- @@ -868,7 +868,7 @@ instance LiftFail FailT where instance LiftError FailT where liftThrow ∷ ∀ e m. (Monad m) ⇒ (∀ a. e → m a) → (∀ a. e → FailT m a) liftThrow throwM e = FailT $ throwM e - + liftCatch ∷ ∀ e m. (Monad m) ⇒ (∀ a. m a → (e → m a) → m a) → (∀ a. FailT m a → (e → FailT m a) → FailT m a) liftCatch catchM xM k = FailT $ catchM (unFailT xM) $ \ e → unFailT $ k e instance (Monad m,MonadError e m) ⇒ MonadError e (FailT m) where @@ -900,7 +900,7 @@ instance (Monad m,MonadCont (𝑂 r) m) ⇒ MonadCont r (FailT m) where callCC ∷ ∀ a. ((a → FailT m r) → FailT m r) → FailT m a callCC kk = FailT $ callCC $ \ (k ∷ 𝑂 a → m (𝑂 r)) → - unFailT $ kk $ \ (x ∷ a) → + unFailT $ kk $ \ (x ∷ a) → FailT $ k $ Some x withC ∷ ∀ a. (a → FailT m r) → FailT m a → FailT m r @@ -918,7 +918,7 @@ instance LiftIO (ErrorT e) where liftIO ioM xM = ErrorT $ do x ← ioM xM return $ Inr x -instance (Monad m,MonadIO m) ⇒ MonadIO (ErrorT e m) where +instance (Monad m,MonadIO m) ⇒ MonadIO (ErrorT e m) where io = liftIO io instance LiftReader (ErrorT e) where @@ -945,7 +945,7 @@ instance LiftWriter (ErrorT e) where case xE of Inl e → return $ Inl e Inr x → return $ Inr (o :* x) -instance (Monad m,MonadWriter o m) ⇒ MonadWriter o (ErrorT e m) where +instance (Monad m,MonadWriter o m) ⇒ MonadWriter o (ErrorT e m) where tell = liftTell tell hijack = liftHijack hijack @@ -976,7 +976,7 @@ instance (Monad m,MonadFail m) ⇒ MonadFail (ErrorT e m) where instance LiftError (ErrorT e) where liftThrow ∷ ∀ e' m. (Monad m) ⇒ (∀ a. e' → m a) → (∀ a. e' → ErrorT e m a) liftThrow throwM e = ErrorT $ throwM e - + liftCatch ∷ ∀ e' m. (Monad m) ⇒ (∀ a. m a → (e' → m a) → m a) → (∀ a. ErrorT e m a → (e' → ErrorT e m a) → ErrorT e m a) liftCatch catchM xM k = ErrorT $ catchM (unErrorT xM) $ \ e → unErrorT $ k e @@ -1005,12 +1005,12 @@ instance (Monad m,MonadCont (e ∨ r) m) ⇒ MonadCont r (ErrorT e m) where callCC ∷ ∀ a. ((a → ErrorT e m r) → ErrorT e m r) → ErrorT e m a callCC kk = ErrorT $ callCC $ \ (k ∷ e ∨ a → m (e ∨ r)) → - unErrorT $ kk $ \ (x ∷ a) → + unErrorT $ kk $ \ (x ∷ a) → ErrorT $ k (Inr x) withC ∷ ∀ a. (a → ErrorT e m r) → ErrorT e m a → ErrorT e m r withC k xM = ErrorT $ - withC + withC (\ (ex ∷ e ∨ a) → case ex of Inl e → return $ Inl e Inr x → unErrorT $ k x) @@ -1022,7 +1022,7 @@ instance (Monad m,MonadCont (e ∨ r) m) ⇒ MonadCont r (ErrorT e m) where instance LiftIO DelayT where liftIO ioM xM = DelayT $ \ () → ioM xM -instance (Monad m,MonadIO m) ⇒ MonadIO (DelayT m) where +instance (Monad m,MonadIO m) ⇒ MonadIO (DelayT m) where io = liftIO io instance LiftReader DelayT where liftAskL askLM ℓ = DelayT $ \ () → askLM ℓ @@ -1033,7 +1033,7 @@ instance (Monad m,MonadReader r m) ⇒ MonadReader r (DelayT m) where instance LiftWriter DelayT where liftTell tellM o = DelayT $ \ () → tellM o liftHijack hijackM xM = DelayT $ \ () → hijackM $ runDelayT xM -instance (Monad m,MonadWriter o m) ⇒ MonadWriter o (DelayT m) where +instance (Monad m,MonadWriter o m) ⇒ MonadWriter o (DelayT m) where tell = liftTell tell hijack = liftHijack hijack instance LiftState DelayT where @@ -1072,11 +1072,11 @@ instance LiftTop DelayT where instance (Monad m,MonadTop m) ⇒ MonadTop (DelayT m) where mtop = liftMtop mtop instance (MonadCont r m) ⇒ MonadCont r (DelayT m) where - callCC 𝓀𝓀 = DelayT $ \ () → + callCC 𝓀𝓀 = DelayT $ \ () → callCC $ \ 𝓀 → runDelayT $ 𝓀𝓀 $ \ x → DelayT $ \ () → 𝓀 x withC 𝓀 xM = DelayT $ \ () → withC (runDelayT ∘ 𝓀) $ runDelayT xM instance (MonadUCont m) ⇒ MonadUCont (DelayT m) where - ucallCC 𝓀𝓀 = DelayT $ \ () → + ucallCC 𝓀𝓀 = DelayT $ \ () → ucallCC (\ 𝓀 → runDelayT $ 𝓀𝓀 $ \ x → DelayT $ \ () → 𝓀 x) uwithC 𝓀 xM = DelayT $ \ () → uwithC (runDelayT ∘ 𝓀) $ runDelayT xM @@ -1103,7 +1103,7 @@ instance LiftReader NondetT where instance (Monad m,MonadReader r m) ⇒ MonadReader r (NondetT m) where askL = liftAskL askL localL = liftLocalL localL - + instance LiftWriter NondetT where liftTell ∷ ∀ m o. (Monad m) ⇒ (o → m ()) → (o → NondetT m ()) liftTell tellM o = NondetT $ do @@ -1174,12 +1174,12 @@ instance (Monad m,Func Monoid m,MonadCont (𝑄 r) m) ⇒ MonadCont r (NondetT m callCC ∷ ∀ a. ((a → NondetT m r) → NondetT m r) → NondetT m a callCC kk = NondetT $ callCC $ \ (k ∷ 𝑄 a → m (𝑄 r)) → - unNondetT $ kk $ \ (x ∷ a) → + unNondetT $ kk $ \ (x ∷ a) → NondetT $ k (single x) withC ∷ ∀ a. (a → NondetT m r) → NondetT m a → NondetT m r withC k xM = NondetT $ - withC + withC (\ (xs ∷ 𝑄 a) → unNondetT $ foldr mzero (⊞) $ map k $ iter xs) (unNondetT xM) @@ -1379,11 +1379,11 @@ instance (Monoid o) ⇒ Transformer (RWST r o s) where deriving instance (Func Null m,Null o,Null s,Null a) ⇒ Null (RWST r o s m a) deriving instance (Func Append m,Append o,Append s,Append a) ⇒ Append (RWST r o s m a) -deriving instance +deriving instance ( Func Null m , Func Append m , Monoid o,Monoid s,Monoid a - ) + ) ⇒ Monoid (RWST r o s m a) type RWS r o s = RWST r o s ID diff --git a/src/UVMHS/Core/Pointed.hs b/src/UVMHS/Core/Pointed.hs index ad2ff763..0f6f63bc 100644 --- a/src/UVMHS/Core/Pointed.hs +++ b/src/UVMHS/Core/Pointed.hs @@ -16,21 +16,21 @@ elimAddNull i f = \case Null → i AddNull x → f x -instance Null (AddNull a) where +instance Null (AddNull a) where null = Null instance (Append a) ⇒ Append (AddNull a) where Null ⧺ x = x x ⧺ Null = x AddNull x ⧺ AddNull y = AddNull $ x ⧺ y instance (Append a) ⇒ Monoid (AddNull a) -instance Functor AddNull where +instance Functor AddNull where map = mmap -instance Return AddNull where +instance Return AddNull where return = AddNull -instance Bind AddNull where +instance Bind AddNull where xM ≫= f = case xM of {Null → Null;AddNull x → f x} instance Monad AddNull -instance FunctorM AddNull where +instance FunctorM AddNull where mapM f xM = case xM of {Null → return Null;AddNull x → map AddNull $ f x} -- === -- @@ -46,21 +46,21 @@ elimZOM i₁ f i₂= \case OneZOM x → f x MoreZOM → i₂ -instance Null (ZOM a) where +instance Null (ZOM a) where null = NullZOM instance Append (ZOM a) where NullZOM ⧺ x = x x ⧺ NullZOM = x _ ⧺ _ = MoreZOM instance Monoid (ZOM a) -instance Functor ZOM where +instance Functor ZOM where map = mmap -instance Return ZOM where +instance Return ZOM where return = OneZOM -instance Bind ZOM where +instance Bind ZOM where xM ≫= f = case xM of {NullZOM → NullZOM;OneZOM x → f x;MoreZOM → MoreZOM} instance Monad ZOM -instance FunctorM ZOM where +instance FunctorM ZOM where mapM f xM = case xM of {NullZOM → return NullZOM;OneZOM x → map OneZOM $ f x;MoreZOM → return MoreZOM} instance Single a (ZOM a) where single = OneZOM @@ -83,13 +83,13 @@ instance (POrd a) ⇒ POrd (AddBot a) where (Bot,AddBot _) → True (AddBot _,Bot) → False (AddBot x,AddBot y) → x ⊑ y -instance Bot (AddBot a) where +instance Bot (AddBot a) where bot = Bot instance (Join a) ⇒ Join (AddBot a) where Bot ⊔ x = x x ⊔ Bot = x AddBot x ⊔ AddBot y = AddBot $ x ⊔ y -instance (Top a) ⇒ Top (AddBot a) where +instance (Top a) ⇒ Top (AddBot a) where top = AddBot top instance (Meet a) ⇒ Meet (AddBot a) where Bot ⊓ _ = Bot @@ -98,14 +98,14 @@ instance (Meet a) ⇒ Meet (AddBot a) where instance (Join a) ⇒ JoinLattice (AddBot a) instance (MeetLattice a) ⇒ MeetLattice (AddBot a) instance (Join a,MeetLattice a) ⇒ Lattice (AddBot a) -instance Functor AddBot where +instance Functor AddBot where map = mmap -instance Return AddBot where +instance Return AddBot where return = AddBot -instance Bind AddBot where +instance Bind AddBot where xM ≫= f = case xM of {Bot → Bot;AddBot x → f x} instance Monad AddBot -instance FunctorM AddBot where +instance FunctorM AddBot where mapM f xM = case xM of {Bot → return Bot;AddBot x → map AddBot $ f x} -- ====== -- @@ -126,13 +126,13 @@ instance (POrd a) ⇒ POrd (AddTop a) where (Top,AddTop _) → False (AddTop _,Top) → True (AddTop x,AddTop y) → x ⊑ y -instance (Bot a) ⇒ Bot (AddTop a) where +instance (Bot a) ⇒ Bot (AddTop a) where bot = AddTop bot instance (Join a) ⇒ Join (AddTop a) where Top ⊔ _ = Top _ ⊔ Top = Top AddTop x ⊔ AddTop y = AddTop $ x ⊔ y -instance Top (AddTop a) where +instance Top (AddTop a) where top = Top instance (Meet a) ⇒ Meet (AddTop a) where Top ⊓ x = x @@ -167,14 +167,14 @@ instance (Times a) ⇒ Times (AddTop a) where _ × Top = Top AddTop x × AddTop y = AddTop $ x × y -instance Functor AddTop where +instance Functor AddTop where map = mmap -instance Return AddTop where +instance Return AddTop where return = AddTop -instance Bind AddTop where +instance Bind AddTop where xM ≫= f = case xM of {Top → Top;AddTop x → f x} instance Monad AddTop -instance FunctorM AddTop where +instance FunctorM AddTop where mapM f xM = case xM of {Top → return Top;AddTop x → map AddTop $ f x} -- ===== -- @@ -184,7 +184,7 @@ instance FunctorM AddTop where data AddBT a = BotBT | AddBT a | TopBT deriving (Eq,Ord,Show) -instance Bot (AddBT a) where +instance Bot (AddBT a) where bot = BotBT instance (Join a) ⇒ Join (AddBT a) where BotBT ⊔ x = x @@ -192,7 +192,7 @@ instance (Join a) ⇒ Join (AddBT a) where TopBT ⊔ _ = TopBT _ ⊔ TopBT = TopBT AddBT x ⊔ AddBT y = AddBT $ x ⊔ y -instance Top (AddBT a) where +instance Top (AddBT a) where top = TopBT instance (Meet a) ⇒ Meet (AddBT a) where BotBT ⊓ _ = BotBT @@ -203,14 +203,14 @@ instance (Meet a) ⇒ Meet (AddBT a) where instance (Join a) ⇒ JoinLattice (AddBT a) instance (Meet a) ⇒ MeetLattice (AddBT a) instance (Join a,Meet a) ⇒ Lattice (AddBT a) -instance Functor AddBT where +instance Functor AddBT where map = mmap -instance Return AddBT where +instance Return AddBT where return = AddBT -instance Bind AddBT where +instance Bind AddBT where xM ≫= f = case xM of {TopBT → TopBT;BotBT → BotBT;AddBT x → f x} instance Monad AddBT -instance FunctorM AddBT where +instance FunctorM AddBT where mapM f xM = case xM of {TopBT → return TopBT;BotBT → return BotBT;AddBT x → map AddBT $ f x} -- LENSES -- @@ -234,4 +234,3 @@ moreZOML ∷ ZOM a ⌲ () moreZOML = prism (const MoreZOM) $ \case MoreZOM → Some () _ → None - diff --git a/src/UVMHS/Core/Static.hs b/src/UVMHS/Core/Static.hs index b81bfd08..bbdf7cf0 100644 --- a/src/UVMHS/Core/Static.hs +++ b/src/UVMHS/Core/Static.hs @@ -57,7 +57,7 @@ wngt_UNSAFE ∷ ∀ m n. P m → P n → W (m ≻ n) wngt_UNSAFE _ _ = weq_UNSAFE @(m ⋚ n ≡ 'GT) @'True P P wnlte_UNSAFE ∷ ∀ m n. P m → P n → W (m ≼ n) -wnlte_UNSAFE _ _ = weq_UNSAFE @((m ⋚ n ≡ 'LT) ⩔ (m ⋚ n ≡ 'EQ)) @'True P P +wnlte_UNSAFE _ _ = weq_UNSAFE @((m ⋚ n ≡ 'LT) ⩔ (m ⋚ n ≡ 'EQ)) @'True P P data (m ∷ 𝐍) < (n ∷ 𝐍) where W_LT ∷ (m ≺ n) ⇒ m < n @@ -165,17 +165,17 @@ type family Prod (ns ∷ [𝐍]) where -- data 𝐿S (is ∷ [i]) (c ∷ i → Constraint) (a ∷ i → ★) ∷ ★ where -- NilS ∷ 𝐿S '[] c a -- (:&&) ∷ (c x) ⇒ a x → 𝐿S xs c a → 𝐿S (x ': xs) c a --- +-- -- map𝐿S ∷ ∀ i (xs ∷ [i]) (c ∷ i → Constraint) (a ∷ i → ★) (b ∷ i → ★) . (∀ (x ∷ i). a x → b x) → 𝐿S xs c a → 𝐿S xs c b -- map𝐿S f = \case -- NilS → NilS -- x :&& xs → f x :&& map𝐿S f xs --- +-- -- append𝐿S ∷ 𝐿S xs c a → 𝐿S ys c a → 𝐿S (xs ⧺ ys) c a -- append𝐿S xs ys = case xs of -- NilS → ys -- x :&& xs' → x :&& append𝐿S xs' ys --- +-- -- iter𝐿S ∷ ∀ i (xs ∷ [i]) (c ∷ i → Constraint) (a ∷ i → ★) (b ∷ ★). (∀ (x ∷ i). (c x) ⇒ a x → b) → 𝐿S xs c a → 𝐼 b -- iter𝐿S f = \case -- NilS → null @@ -191,7 +191,7 @@ type family AllC (c ∷ a → Constraint) (xs ∷ [a]) ∷ Constraint where -- instance (∀ x. (c x) ⇒ Plus (a x)) ⇒ Plus (𝐿S xs c a) where -- NilS + NilS = NilS -- x :&& xs + y :&& ys = (x + y) :&& (xs + ys) --- +-- -- instance (∀ x. (c x) ⇒ Times (a x)) ⇒ Times (𝐿S xs c a) where -- NilS × NilS = NilS -- x :&& xs × y :&& ys = (x × y) :&& (xs × ys) @@ -209,10 +209,10 @@ instance (HasSpine xs) ⇒ HasSpine (x ': xs) where spine = ConsSpine spine -- zero𝐿S = \case -- NilSpine → NilS -- ConsSpine sp → zero :&& zero𝐿S sp --- +-- -- instance (HasSpine xs,AllC c xs,∀ x. (c x) ⇒ Zero (a x)) ⇒ Zero (𝐿S xs c a) where -- zero = zero𝐿S spine --- +-- -- type family PrependMany (xs ∷ [a]) (xxs ∷ [[a]]) ∷ [[a]] where -- PrependMany _ '[] = '[] -- PrependMany xs (xs' ': xss) = (xs ⧺ xs') ': PrependMany xs xss @@ -225,7 +225,7 @@ newtype 𝕀64 (n ∷ 𝐍) = 𝕀64_UNSAFE { un𝕀64 ∷ ℕ64 } 𝕚64 m = 𝕀64_UNSAFE $ unℕ64S m 𝕚64d ∷ ∀ n. (𝒩64 n) ⇒ ℕ64 → 𝑂 (𝕀64 n) -𝕚64d m = +𝕚64d m = if m < unℕ64S (𝕟64s @n) then Some $ 𝕀64_UNSAFE m else None @@ -254,22 +254,22 @@ instance ToIter a (𝐼S n a) where iter = un𝐼S -- infixl 5 +♮ -- infixl 6 ×♮ --- +-- -- class ZeroS t where zeroS ∷ t 0 -- class OneS t where oneS ∷ t 1 -- class PlusS t where (+♮) ∷ t m → t n → t (m + n) -- class TimesS t where (×♮) ∷ t m → t n → t (m × n) --- +-- -- instance ZeroS ℕ64S where zeroS = 𝕟64s @0 -- instance OneS ℕ64S where oneS = 𝕟64s @1 -- instance PlusS ℕ64S where m +♮ n = ℕ64S_UNSAFE $ unℕ64S m + unℕ64S n -- instance TimesS ℕ64S where m ×♮ n = ℕ64S_UNSAFE $ unℕ64S m × unℕ64S n -class NullS t where +class NullS t where nullS ∷ t 0 a class SingleS t where 𝔢 ∷ a → t 1 a -class AppendS t where +class AppendS t where (⧺♮) ∷ t n₁ a → t n₂ a → t (n₁ + n₂) a -- class AppendSL t where -- (⧺♭) ∷ t ns₁ a → t ns₂ a → t (ns₁ ⧺ ns₂) a diff --git a/src/UVMHS/Core/TH.hs b/src/UVMHS/Core/TH.hs index 6933eefa..8aa4b52f 100644 --- a/src/UVMHS/Core/TH.hs +++ b/src/UVMHS/Core/TH.hs @@ -29,17 +29,17 @@ instance Apply TH.Exp where (⊙) = TH.AppE -- instance Tup TH.Pat where tup = TH.TupP ∘ lazyList -- instance Tup TH.Type where tup ts = TH.TupleT (tohs $ intΩ64 $ count ts) ⊙⋆ ts -instance Tup TH.Exp where +instance Tup TH.Exp where tup es = case list es of Nil → TH.ConE '() e :& es' → foldOnFrom es' e $ \ e' eᵢ → TH.ConE '(:*) ⊙ eᵢ ⊙ e' -instance Tup TH.Pat where +instance Tup TH.Pat where tup ps = case list ps of Nil → TH.ConP '() [] [] p :& ps' → foldOnFrom ps' p $ \ p' pᵢ → TH.ConP '(:*) [] [pᵢ,p'] -instance Tup TH.Type where +instance Tup TH.Type where tup ts = case list ts of Nil → TH.ConT ''() t :& ts' → foldOnFrom ts' t $ \ t' tᵢ → TH.ConT ''(∧) ⊙ tᵢ ⊙ t' @@ -49,7 +49,7 @@ instance Arrow TH.Type where f ⇨ x = TH.ArrowT ⊙ f ⊙ x thString ∷ 𝕊 → TH.Exp thString = TH.LitE ∘ TH.StringL ∘ lazyList - + thConNames ∷ TH.Con → 𝐿 TH.Name thConNames (TH.NormalC n _) = single n thConNames (TH.RecC n _) = single n @@ -126,10 +126,10 @@ thLoc𝕊 ∷ TH.Q 𝕊 thLoc𝕊 = do l ← TH.location return $ concat - [ frhsChars $ TH.loc_module l - , "@" - , show𝕊 $ TH.loc_start l - , ":" + [ frhsChars $ TH.loc_module l + , "@" + , show𝕊 $ TH.loc_start l + , ":" , show𝕊 $ TH.loc_end l ] diff --git a/src/UVMHS/Core/Transformers.hs b/src/UVMHS/Core/Transformers.hs index 819b3190..26c135fc 100644 --- a/src/UVMHS/Core/Transformers.hs +++ b/src/UVMHS/Core/Transformers.hs @@ -16,7 +16,7 @@ infixl 7 ⊡ newtype (⊡) (t₁ ∷ (★ → ★) → (★ → ★)) (t₂ ∷ (★ → ★) → (★ → ★)) m a = Compose2 { unCompose2 ∷ t₁ (t₂ m) a } -instance (∀ m'. Monad m' ⇒ Monad (t₁ m'),∀ m'. Monad m' ⇒ Monad (t₂ m'),Monad m) ⇒ Functor ((t₁ ⊡ t₂) m) where +instance (∀ m'. Monad m' ⇒ Monad (t₁ m'),∀ m'. Monad m' ⇒ Monad (t₂ m'),Monad m) ⇒ Functor ((t₁ ⊡ t₂) m) where map = mmap instance (∀ m'. Monad m' ⇒ Monad (t₁ m'),∀ m'. Monad m' ⇒ Monad (t₂ m'),Monad m) ⇒ Return ((t₁ ⊡ t₂) m) where return ∷ ∀ a. a → (t₁ ⊡ t₂) m a diff --git a/src/UVMHS/Core/VectorSparse.hs b/src/UVMHS/Core/VectorSparse.hs index 5403820d..a7b2174b 100644 --- a/src/UVMHS/Core/VectorSparse.hs +++ b/src/UVMHS/Core/VectorSparse.hs @@ -19,7 +19,7 @@ instance (POrd a) ⇒ POrd (𝑉 a) where (⊑) = subDictBy𝑉 (⊑) instance Null (𝑉 a) where null = wø instance (Append a) ⇒ Append (𝑉 a) where (⧺) = unionWith𝑉 (⧺) -instance (Append a) ⇒ Monoid (𝑉 a) +instance (Append a) ⇒ Monoid (𝑉 a) instance (Null a) ⇒ Unit (𝑉 a) where unit = null ↦♮ null instance (Append a,Cross a) ⇒ Cross (𝑉 a) where @@ -53,7 +53,7 @@ instance Functor 𝑉 where map = map𝑉 instance ToIter (ℤ64 ∧ a) (𝑉 a) where iter = iter𝑉 -instance (Show a) ⇒ Show (𝑉 a) where +instance (Show a) ⇒ Show (𝑉 a) where show = tohsChars ∘ showCollection "{" "}" "," (\ (i :* x) → show𝕊 i ⧺ "⇒" ⧺ show𝕊 x) lookup𝑉 ∷ 𝑉 a → ℤ64 → 𝑂 a @@ -70,7 +70,7 @@ wø = 𝑉 IntMap.empty unionWith𝑉 ∷ (a → a → a) → 𝑉 a → 𝑉 a → 𝑉 a unionWith𝑉 f ixs₁ ixs₂ = 𝑉 $ IntMap.unionWith f (un𝑉 ixs₁) (un𝑉 ixs₂) - + (↦♮) ∷ ℤ64 → a → 𝑉 a i ↦♮ x = 𝑉 $ IntMap.singleton (tohs i) x @@ -82,7 +82,7 @@ ixs₁ ⩌♮ ixs₂ = 𝑉 $ un𝑉 ixs₁ `IntMap.union` un𝑉 ixs₂ (⩍♮) ∷ 𝑉 a → 𝑉 a → 𝑉 a ixs₁ ⩍♮ ixs₂ = 𝑉 $ un𝑉 ixs₁ `IntMap.intersection` un𝑉 ixs₂ - + -- (∸♮) ∷ 𝑉 a → 𝑉 a → 𝑉 a -- ixs₁ ∸♮ ixs₂ = 𝑉 $ un𝑉 ixs₁ `IntMap.difference` un𝑉 ixs₂ @@ -97,7 +97,7 @@ size𝑉 = HS.fromIntegral ∘ IntMap.size ∘ un𝑉 unionsWith𝑉 ∷ (ToIter (𝑉 a) t) ⇒ (a → a → a) → t → 𝑉 a unionsWith𝑉 = fold wø ∘ unionWith𝑉 - + interWith𝑉 ∷ (a → b → c) → 𝑉 a → 𝑉 b → 𝑉 c interWith𝑉 f ixs₁ ixs₂ = 𝑉 $ IntMap.intersectionWith f (un𝑉 ixs₁) (un𝑉 ixs₂) @@ -147,7 +147,7 @@ spvec𝐼 = 𝑉 ∘ IntMap.fromList ∘ lazyList ∘ map tohs spvec ∷ (ToIter (𝑉 a) t) ⇒ t → 𝑉 a spvec = foldr wø (⩌♮) ∘ iter - + assoc𝑉 ∷ (ToIter (ℤ64 ∧ a) t) ⇒ t → 𝑉 a assoc𝑉 = spvec ∘ map single ∘ iter diff --git a/src/UVMHS/Lang/ULC.hs b/src/UVMHS/Lang/ULC.hs index 113929c1..cc3f6635 100644 --- a/src/UVMHS/Lang/ULC.hs +++ b/src/UVMHS/Lang/ULC.hs @@ -27,10 +27,10 @@ type ULCExpSrc = ULCExp SrcCxt type ULCExpRaw = ULCExp () lexULCExp ∷ Lexer CharClass ℂ TokenClassBasic ℕ64 TokenBasic -lexULCExp = - lexerBasic (list ["(",")","->","→","^","↑",":"]) - (list ["lam","λ"]) - (list ["glbl","𝔤","meta","𝔪"]) +lexULCExp = + lexerBasic (list ["(",")","->","→","^","↑",":"]) + (list ["lam","λ"]) + (list ["glbl","𝔤","meta","𝔪"]) null pULCExp ∷ CParser TokenBasic ULCExpSrc @@ -65,7 +65,7 @@ pULCExp = ULCExp ^$ fmixfixWithContext "exp" $ concat xO ← cpOptional $ cpVar void $ concat $ map cpSyntax ["->","→"] return $ \ e → Lam_ULC xO $ ULCExp e - , fmixInfixL pAPP $ return $ \ e₁ e₂ → + , fmixInfixL pAPP $ return $ \ e₁ e₂ → App_ULC (ULCExp e₁) $ ULCExp e₂ ] diff --git a/src/UVMHS/Lib/Dataframe.hs b/src/UVMHS/Lib/Dataframe.hs index b019823a..63da1e27 100644 --- a/src/UVMHS/Lib/Dataframe.hs +++ b/src/UVMHS/Lib/Dataframe.hs @@ -28,7 +28,7 @@ frameTypeCode = \case D_FT → "dbl" S_FT → "str" -data FrameVal = +data FrameVal = B_FV 𝔹 | N_FV ℕ64 | Z_FV ℤ64 @@ -105,10 +105,10 @@ instance FunctorM FrameGrouping where S_FG kvs → S_FG ^$ mapM f kvs frameGroupingInterWithM - ∷ (Monad m,MonadFail m) - ⇒ (v₁ → v₂ → m v₃) - → FrameGrouping v₁ - → FrameGrouping v₂ + ∷ (Monad m,MonadFail m) + ⇒ (v₁ → v₂ → m v₃) + → FrameGrouping v₁ + → FrameGrouping v₂ → m (FrameGrouping v₃) frameGroupingInterWithM f vs₁ vs₂ = case (vs₁,vs₂) of (B_FG kvs₁,B_FG kvs₂) → B_FG ^$ dinterByM f kvs₁ kvs₂ @@ -155,7 +155,7 @@ frameProduct fr₁ fr₂ = do colt' = colt₁' ⩌ colt₂' grpt' ∷ 𝕊 ⇰ FrameType ← dinterByM (\ τ₁ τ₂ → do guard $ τ₁ ≡ τ₂ ; return τ₁) grpt₁ grpt₂ - let data' = dinterByOn data₁ data₂ $ \ (n₁ :* svss₁) (n₂ :* svss₂) → + let data' = dinterByOn data₁ data₂ $ \ (n₁ :* svss₁) (n₂ :* svss₂) → let svss₁'₁ ∷ 𝕊 ⇰ FrameCol svss₁'₁ = assoc $ mapOn (iter svss₁) $ mapFst $ flip (⧺) "_L" svss₂'₁ ∷ 𝕊 ⇰ FrameCol @@ -171,7 +171,7 @@ frameProduct fr₁ fr₂ = do rows = csize svss'₁ - svss'₂ = kmapOn colt' $ \ s τ → + svss'₂ = kmapOn colt' $ \ s τ → viewΩ someL $ frameColPack τ $ mapOn (iterC svss'₁) $ lupΩ s in rows :* svss'₂ return $ Frame colp' colv' colt' grpt' data' @@ -186,7 +186,7 @@ frameGroup col s₀ (Frame colp colv colt grpt data') = do colv' ∷ 𝕍 𝕊 colv' = vec $ filter (≢ col) colv colt' ∷ 𝕊 ⇰ FrameType - colt' = dtoss (single col) colt + colt' = dtoss (single col) colt grpt' ∷ 𝕊 ⇰ FrameType grpt' = dict [s₀ ↦ colt ⋕! col,grpt] data'₁ ∷ (𝕊 ⇰ FrameVal) ⇰ FrameVal ⇰ ℕ64 ∧ (𝕊 ⇰ FrameCol) @@ -196,14 +196,14 @@ frameGroup col s₀ (Frame colp colv colt grpt data') = do svss'₁ ∷ 𝕊 ⇰ FrameCol svss'₁ = dtoss (single col) svss svss'₂ ∷ FrameVal ⇰ 𝐼C (𝕊 ⇰ FrameVal) - svss'₂ = concat $ mapOn (upto n) $ \ nᵢ → + svss'₂ = concat $ mapOn (upto n) $ \ nᵢ → let vᵢ = viewΩ someL $ frameColIndex nᵢ svs svsᵢ = mapOn svss'₁ $ viewΩ someL ∘ frameColIndex nᵢ in vᵢ ↦ single svsᵢ svss'₃ ∷ FrameVal ⇰ ℕ64 ∧ (𝕊 ⇰ FrameCol) svss'₃ = mapOn svss'₂ $ \ svssᵢ → let rows = csize svssᵢ - svsᵢ = kmapOn colt' $ \ s τ → + svsᵢ = kmapOn colt' $ \ s τ → viewΩ someL $ frameColPack τ $ mapOn svssᵢ $ lupΩ s in rows :* svsᵢ in svss'₃ @@ -229,9 +229,9 @@ frameUngroup grp s₀ (Frame colp colv colt grpt data') = do grpt' ∷ 𝕊 ⇰ FrameType grpt' = dtoss (single grp) grpt data'₁ ∷ (𝕊 ⇰ FrameVal) ⇰ ℕ64 ∧ (𝕊 ⇰ 𝐼C FrameVal) - data'₁ = concat $ mapOn (iter data') $ \ (svs :* (n :* svss)) → + data'₁ = concat $ mapOn (iter data') $ \ (svs :* (n :* svss)) → let svs' ∷ 𝕊 ⇰ FrameVal - svs' = dtoss (single grp) svs + svs' = dtoss (single grp) svs v ∷ FrameVal v = svs ⋕! grp svss' ∷ 𝕊 ⇰ 𝐼C FrameVal @@ -242,7 +242,7 @@ frameUngroup grp s₀ (Frame colp colv colt grpt data') = do in svs' ↦ n :* svss' data'₂ ∷ (𝕊 ⇰ FrameVal) ⇰ ℕ64 ∧ (𝕊 ⇰ FrameCol) - data'₂ = mapOn data'₁ $ \ (n :* svss) → + data'₂ = mapOn data'₁ $ \ (n :* svss) → let svss' ∷ 𝕊 ⇰ FrameCol svss' = kmapOn svss $ \ s vs → let τ ∷ FrameType @@ -277,9 +277,9 @@ frameValParse s = \case frameParse ∷ 𝕊 → IO Frame frameParse s = do - sss ∷ 𝕍 (𝕍 𝕊) ← - elimChoice (failIO ∘ string) (return ∘ map (map (Text.decodeUtf8 ∘ BSL.toStrict) ∘ 𝕍) ∘ 𝕍) $ - frhs $ CSV.decode @(Vector.Vector BSL.ByteString) CSV.NoHeader $ + sss ∷ 𝕍 (𝕍 𝕊) ← + elimChoice (failIO ∘ string) (return ∘ map (map (Text.decodeUtf8 ∘ BSL.toStrict) ∘ 𝕍) ∘ 𝕍) $ + frhs $ CSV.decode @(Vector.Vector BSL.ByteString) CSV.NoHeader $ BSL.fromStrict $ Text.encodeUtf8 s cols ∷ 𝐿 𝕊 ← ifNoneM (failIO "bad1") $ list ^$ sss ⋕? 0 typs ∷ 𝐿 𝕊 ← ifNoneM (failIO "bad2") $ list ^$ sss ⋕? 1 @@ -303,33 +303,33 @@ frameParse s = do v ← frameValParse sᵢ t return $ key :* v let svss' ∷ 𝕊 ⇰ FrameCol - svss' = kmapOn coltyps' $ \ sᵢ τ → + svss' = kmapOn coltyps' $ \ sᵢ τ → viewΩ someL $ frameColPack τ $ mapOn (iterC svss) $ lupΩ sᵢ return $ Frame (pow cols) (vec cols) (assoc coltyps) null $ null ↦ (rows :* svss') instance Pretty Frame where - pretty (Frame _colp colv colt grps data') = - let data'' = mapOn data' $ \ (rows :* svss) → + pretty (Frame _colp colv colt grps data') = + let data'' = mapOn data' $ \ (rows :* svss) → let svss' ∷ 𝕊 ⇰ 𝕍 𝕊 svss' = map (vecC ∘ map ppshow ∘ frameColUnpack) svss colWidths ∷ 𝕍 (𝕊 ∧ ℕ64) - colWidths = mapOn colv $ \ col → + colWidths = mapOn colv $ \ col → (:*) col $ joins [ csize col , csize $ frameTypeCode $ colt ⋕! col , joins $ map csize $ svss' ⋕! col ] - in + in concat [ ppForceBreak , ppVertical - [ ppHorizontal $ inbetween (ppComment "|") $ mapOn colWidths $ \ (col :* width) → + [ ppHorizontal $ inbetween (ppComment "|") $ mapOn colWidths $ \ (col :* width) → ppCon $ alignLeft (nat width) col - , ppComment $ string $ + , ppComment $ string $ replicate (sum [sum $ map snd colWidths,(count colWidths ⊔ 1 - 1) × 3]) '-' , ppHorizontal $ inbetween (ppComment "|") $ mapOn colWidths $ \ (col :* width) → ppComment $ alignLeft (nat width) $ frameTypeCode $ colt ⋕! col - , ppComment $ string $ + , ppComment $ string $ replicate (sum [sum $ map snd colWidths,(count colWidths ⊔ 1 - 1) × 3]) '-' , ppVertical $ mapOn (upto rows) $ \ n → ppHorizontal $ inbetween (ppComment "|") $ mapOn colWidths $ \ (col :* width) → @@ -337,8 +337,7 @@ instance Pretty Frame where , ppComment $ "⇈ ROWS: " ⧺ show𝕊 rows ] ] - in + in if | isEmpty grps → pretty $ data'' ⋕! null | otherwise → pretty data'' - diff --git a/src/UVMHS/Lib/GTree.hs b/src/UVMHS/Lib/GTree.hs index 9ba30663..3e1f1129 100644 --- a/src/UVMHS/Lib/GTree.hs +++ b/src/UVMHS/Lib/GTree.hs @@ -2,50 +2,50 @@ module UVMHS.Lib.GTree where -- import UVMHS.Core -- import UVMHS.Lib.Pretty --- --- data GTree a = GTree +-- +-- data GTree a = GTree -- { gtreeValues ∷ 𝐼 a -- , gtreeNested ∷ 𝕊 ⇰ GTree a -- } deriving (Show) --- --- instance Null (GTree a) where +-- +-- instance Null (GTree a) where -- null = GTree null null --- instance Append (GTree a) where +-- instance Append (GTree a) where -- GTree m₁ n₁ ⧺ GTree m₂ n₂ = GTree (m₁ ⧺ m₂) $ n₁ ⧺ n₂ -- instance Monoid (GTree a) --- --- instance Eps (GTree a) where +-- +-- instance Eps (GTree a) where -- eps = GTree null null -- instance Seq (GTree a) where -- GTree v₁ n₁ ▷ GTree v₂ n₂ -- | isEmpty $ list n₁ = GTree (v₁ ⧺ v₂) n₂ -- | otherwise = GTree v₁ $ assoc $ map (mapSnd (▷ GTree v₂ n₂)) $ iter n₁ -- instance Seqoid (GTree a) --- +-- -- instance Single a (GTree a) where -- single = gtv --- +-- -- foldGTreeWith ∷ (Monoid b) ⇒ (𝐼 a → b) → (𝕊 → b → b) → GTree a → b -- foldGTreeWith fₗ fₙ = loop --- where +-- where -- loop (GTree vs sxs) = concat -- [ fₗ vs -- , concat $ mapOn (iter sxs) $ \ (s :* xs) → -- fₙ s $ loop xs -- ] --- +-- -- foldGTreeOn ∷ (Monoid b) ⇒ GTree a → (𝐼 a → b) → (𝕊 → b → b) → b -- foldGTreeOn = rotateR foldGTreeWith --- +-- -- gtk ∷ 𝕊 → GTree a → GTree a -- gtk s x = GTree null $ single $ s :* x --- +-- -- gtks ∷ 𝐿 𝕊 → GTree a → GTree a -- gtks ss x = foldrOnFrom ss x gtk --- +-- -- gtv ∷ a → GTree a -- gtv x = GTree (single x) null --- +-- -- instance (Pretty a) ⇒ Pretty (GTree a) where -- pretty (GTree v n) = ppVertical $ concat -- [ map pretty v @@ -54,4 +54,4 @@ module UVMHS.Lib.GTree where -- , ppGA $ pretty v' -- ] -- ] --- +-- diff --git a/src/UVMHS/Lib/Graph.hs b/src/UVMHS/Lib/Graph.hs index d33b62bc..3a24e663 100644 --- a/src/UVMHS/Lib/Graph.hs +++ b/src/UVMHS/Lib/Graph.hs @@ -7,7 +7,7 @@ type Graph a = a ⇰ 𝑃 a graphTranspose ∷ ∀ a. (Ord a) ⇒ Graph a → Graph a graphTranspose kvs = joins [ dict $ mapOn (iter $ dkeys kvs) $ \ k → k ↦ pø - , joins $ mapOn (iter kvs) $ \ (k :* vs) → + , joins $ mapOn (iter kvs) $ \ (k :* vs) → dict $ mapOn (iter vs) $ \ v → v ↦ single k ] @@ -22,7 +22,7 @@ kosaraju g = else let visited' = single u ∪ visited visited'' :* stack' = - foldOnFrom (g ⋕! u) (visited' :* stack) $ \ v (visitedᵢ :* stackᵢ) → + foldOnFrom (g ⋕! u) (visited' :* stack) $ \ v (visitedᵢ :* stackᵢ) → visit v visitedᵢ stackᵢ stack'' = u :& stack' in visited'' :* stack'' @@ -63,12 +63,12 @@ sccGroups deps = sccsDefuse = kosaraju graph -- throw out def/use information and just map variables to groups sccs ∷ a ⇰ a - sccs = dict $ mapOn (iter sccsDefuse) $ \ ((x₁ :* b) :* (x₂ :* _)) → + sccs = dict $ mapOn (iter sccsDefuse) $ \ ((x₁ :* b) :* (x₂ :* _)) → if b then x₁ ↦ x₂ else null -- map group ids to variables in that group, and all dependencies of -- that group groups ∷ a ⇰ 𝑃 a ∧ 𝑃 a - groups = joins $ mapOn (iter sccs) $ \ (x₁ :* x₂) → + groups = joins $ mapOn (iter sccs) $ \ (x₁ :* x₂) → x₂ ↦ single x₁ :* (deps ⋕! x₁) in sccs :* groups diff --git a/src/UVMHS/Lib/MMSP.hs b/src/UVMHS/Lib/MMSP.hs index c534dcc1..2a556c78 100644 --- a/src/UVMHS/Lib/MMSP.hs +++ b/src/UVMHS/Lib/MMSP.hs @@ -8,24 +8,24 @@ import UVMHS.Lib.Annotated -- import UVMHS.Lib.Substitution -- MMSP ≈ --- c ⊔ (c ⊓ (c + c(xᶜ…xᶜ) --- ⋮ ⋮ ⋮ --- ⋮ ⋮ + c(xᵈ…xᵈ)) --- ⋮ ⋮ --- ⋮ ⊓ (c + c(xᶜ…xᶜ) --- ⋮ ⋮ +-- c ⊔ (c ⊓ (c + c(xᶜ…xᶜ) +-- ⋮ ⋮ ⋮ +-- ⋮ ⋮ + c(xᵈ…xᵈ)) +-- ⋮ ⋮ +-- ⋮ ⊓ (c + c(xᶜ…xᶜ) +-- ⋮ ⋮ -- ⋮ + c(xᵈ…xᵈ)) --- ⊔ (c ⊓ (c + c(xᶜ…xᶜ) --- ⋮ ⋮ --- ⋮ + c(xᵈ…xᵈ)) --- ⋮ --- ⊓ (c + c(xᶜ…xᶜ) --- ⋮ +-- ⊔ (c ⊓ (c + c(xᶜ…xᶜ) +-- ⋮ ⋮ +-- ⋮ + c(xᵈ…xᵈ)) +-- ⋮ +-- ⊓ (c + c(xᶜ…xᶜ) +-- ⋮ -- + c(xᵈ…xᵈ)) newtype MMSP = MMSP { mmspMaxs ∷ MMSPMaxs - } + } deriving (Eq,Ord,Show) data MMSPMaxs = MMSPMaxs @@ -51,7 +51,7 @@ data MMSPProds = MMSPProds } deriving (Eq,Ord,Show) -data MMSPAtom = +data MMSPAtom = Var_MMSPAtom (𝐴 (𝑃 SrcCxt) 𝕏) deriving (Eq,Ord,Show) makePrisms ''MMSPAtom @@ -83,7 +83,7 @@ maxsMMSPL ∷ MMSP ⌲ MMSPMaxs maxsMMSPL = prism MMSP $ Some ∘ mmspMaxs minsMMSPL ∷ MMSP ⌲ MMSPMins -minsMMSPL = +minsMMSPL = let mk β̇ = MMSPMaxs zero $ single β̇ vw = \case MMSPMaxs a α | a ≡ zero,Some β̇ ← view single𝑃L α → Some β̇ @@ -91,7 +91,7 @@ minsMMSPL = in prism mk vw ⊚ maxsMMSPL sumsMMSPL ∷ MMSP ⌲ MMSPSums -sumsMMSPL = +sumsMMSPL = let mk γ̇ = MMSPMins Top $ single $ γ̇ vw = \case MMSPMins b β | b ≡ Top,Some γ̇ ← view single𝑃L β → Some γ̇ @@ -99,7 +99,7 @@ sumsMMSPL = in prism mk vw ⊚ minsMMSPL prodsMMSPL ∷ MMSP ⌲ MMSPProds -prodsMMSPL = +prodsMMSPL = let mk δ̇ = MMSPSums zero $ δ̇ ↦♭ one vw = \case MMSPSums c γ | c ≡ zero,Some (δ̇ :* d) ← view single𝐷L γ,d ≡ one → Some δ̇ @@ -118,7 +118,7 @@ varMMSPL ∷ MMSP ⌲ 𝐴 (𝑃 SrcCxt) 𝕏 varMMSPL = var_MMSPAtomL ⊚ atomMMSPL litMMSPL ∷ MMSP ⌲ ℕ -litMMSPL = +litMMSPL = let mk n = MMSPMaxs n null vw = \case MMSPMaxs a α | isEmpty α → Some a @@ -126,7 +126,7 @@ litMMSPL = in prism mk vw ⊚ maxsMMSPL topMMSPL ∷ MMSP ⌲ () -topMMSPL = +topMMSPL = let mk () = MMSPMins Top null vw = \case MMSPMins b β | b ≡ Top,isEmpty β → Some () @@ -138,7 +138,7 @@ littMMSPL = let mk = \case AddTop n → litMMSP n Top → topMMSP - vw η + vw η | Some n ← view litMMSPL η = Some $ AddTop n | Some () ← view topMMSPL η = Some Top | otherwise = None @@ -189,36 +189,36 @@ ponMMSP e n = product $ replicate n e -- gsubstMMSP ∷ (Substy t,Monad m) ⇒ (a → m MMSP) → t a → MMSP → m MMSP -- gsubstMMSP 𝓋 𝓈 (MMSP α̇) = gsubstMMSPMaxs 𝓋 𝓈 α̇ --- +-- -- gsubstMMSPMaxs ∷ (Substy t,Monad m) ⇒ (a → m MMSP) → t a → MMSPMaxs → m MMSP -- gsubstMMSPMaxs 𝓋 𝓈 (MMSPMaxs a α) = (litMMSP a ⊔) ^$ gsubstMMSPMaxsMins 𝓋 𝓈 α --- +-- -- gsubstMMSPMaxsMins ∷ (Substy t,Monad m) ⇒ (a → m MMSP) → t a → 𝑃 MMSPMins → m MMSP -- gsubstMMSPMaxsMins 𝓋 𝓈 α = joins ^$ mapM (gsubstMMSPMins 𝓋 𝓈) $ iter α --- +-- -- gsubstMMSPMins ∷ (Substy t,Monad m) ⇒ (a → m MMSP) → t a → MMSPMins → m MMSP -- gsubstMMSPMins 𝓋 𝓈 (MMSPMins b β) = (elimAddTop top litMMSP b ⊓) ^$ gsubstMMSPMinsSums 𝓋 𝓈 β --- +-- -- gsubstMMSPMinsSums ∷ (Substy t,Monad m) ⇒ (a → m MMSP) → t a → 𝑃 MMSPSums → m MMSP -- gsubstMMSPMinsSums 𝓋 𝓈 β = meets ^$ mapM (gsubstMMSPSums 𝓋 𝓈) $ iter β --- +-- -- gsubstMMSPSums ∷ (Substy t,Monad m) ⇒ (a → m MMSP) → t a → MMSPSums → m MMSP -- gsubstMMSPSums 𝓋 𝓈 (MMSPSums c γ) = (litMMSP c +) ^$ gsubstMMSPSumsProds 𝓋 𝓈 γ --- +-- -- gsubstMMSPSumsProds ∷ (Substy t,Monad m) ⇒ (a → m MMSP) → t a → MMSPProds ⇰ ℕ → m MMSP --- gsubstMMSPSumsProds 𝓋 𝓈 γ = sum ^$ mapMOn (iter γ) $ \ (δ :* d) → +-- gsubstMMSPSumsProds 𝓋 𝓈 γ = sum ^$ mapMOn (iter γ) $ \ (δ :* d) → -- (litMMSP d ×) ^$ gsubstMMSPProds 𝓋 𝓈 δ --- +-- -- gsubstMMSPProds ∷ (Substy t,Monad m) ⇒ (a → m MMSP) → t a → MMSPProds → m MMSP --- gsubstMMSPProds 𝓋 𝓈 (MMSPProds δ) = product ^$ mapMOn (iter δ) $ \ (ω :* e) → +-- gsubstMMSPProds 𝓋 𝓈 (MMSPProds δ) = product ^$ mapMOn (iter δ) $ \ (ω :* e) → -- (^^ e) ^$ gsubstMMSPAtom 𝓋 𝓈 ω --- +-- -- gsubstMMSPAtom ∷ (Substy t,Monad m) ⇒ (a → m MMSP) → t a → MMSPAtom → m MMSP -- gsubstMMSPAtom 𝓋 𝓈 = \case -- Var_MMSPAtom (𝐴 𝒸 𝓎) → case 𝓈var 𝓈 𝓎 of -- Inl 𝓎' → return $ varMMSP $ 𝐴 𝒸 𝓎' -- Inr (𝓈O :* e) → elim𝑂 return (gsubstMMSP exfalso) 𝓈O *$ 𝓋 e --- +-- -- instance Substable m () MMSP MMSP where gsubstS 𝓋 𝓈 = gsubstMMSP 𝓋 $ ifNone null $ 𝓈 ⋕? () --------------- @@ -227,19 +227,19 @@ ponMMSP e n = product $ replicate n e -- fvMMSP ∷ MMSP → 𝑃 𝕐 -- fvMMSP (MMSP α̇) = fvMMSPMaxs α̇ --- +-- -- fvMMSPMaxs ∷ MMSPMaxs → 𝑃 𝕐 -- fvMMSPMaxs (MMSPMaxs _ α) = joins $ map fvMMSPMins $ iter α --- +-- -- fvMMSPMins ∷ MMSPMins → 𝑃 𝕐 -- fvMMSPMins (MMSPMins _ β) = joins $ map fvMMSPSums $ iter β --- +-- -- fvMMSPSums ∷ MMSPSums → 𝑃 𝕐 -- fvMMSPSums (MMSPSums _ γ) = joins $ map (fvMMSPProds ∘ fst) $ iter γ --- +-- -- fvMMSPProds ∷ MMSPProds → 𝑃 𝕐 -- fvMMSPProds (MMSPProds δ) = joins $ map (fvMMSPAtom ∘ fst) $ iter δ --- +-- -- fvMMSPAtom ∷ MMSPAtom → 𝑃 𝕐 -- fvMMSPAtom = \case -- Var_MMSPAtom xA → fv $ aval xA @@ -269,7 +269,7 @@ joinMaxsMins α₁ α₂ = α₁ ∪ α₂ -- │b ∧̃ α│ -- └─────┘ cmeetMaxsMins ∷ AddTop ℕ → 𝑃 MMSPMins → 𝑃 MMSPMins --- b ∧̃ α = c ⊓ ⨆{ β | β ∈ α} +-- b ∧̃ α = c ⊓ ⨆{ β | β ∈ α} -- ≜ ⨆ { b ∧̃ β | β ∈ α} cmeetMaxsMins b = pow ∘ map (cmeetMins b) ∘ iter @@ -285,7 +285,7 @@ meetMaxsMins α₁ α₂ = pow $ mapOn (iter α₁ ⧆ iter α₂) $ \ (β₁ :* -- │c +̃ α│ -- └─────┘ cplusMaxsMins ∷ ℕ → 𝑃 MMSPMins → 𝑃 MMSPMins --- c +̃ α = c + ⨆{ β | β ∈ α} +-- c +̃ α = c + ⨆{ β | β ∈ α} -- ≜ ⨆ { c +̃ β | β ∈ α} cplusMaxsMins c = pow ∘ map (cplusMins c) ∘ iter @@ -301,7 +301,7 @@ plusMaxsMins α₁ α₂ = pow $ mapOn (iter α₁ ⧆ iter α₂) $ \ (β₁ :* -- │d ×̃ α│ -- └─────┘ ctimesMaxsMins ∷ ℕ → 𝑃 MMSPMins → 𝑃 MMSPMins --- d ×̃ α = d × ⨆{ β | β ∈ α} +-- d ×̃ α = d × ⨆{ β | β ∈ α} -- ≜ ⨆ { d ×̃ β | β ∈ α} ctimesMaxsMins d = pow ∘ map (ctimesMins d) ∘ iter @@ -319,7 +319,7 @@ timesMaxsMins α₁ α₂ = pow $ mapOn (iter α₁ ⧆ iter α₂) $ \ (β₁ : -- │α̇ ∨̃ α̇│ -- └─────┘ joinMaxs ∷ MMSPMaxs → MMSPMaxs → MMSPMaxs --- +-- joinMaxs (MMSPMaxs a₁ α₁) (MMSPMaxs a₂ α₂) = MMSPMaxs (a₁ ⊔ a₂) $ joinMaxsMins α₁ α₂ -- ┌─────┐ @@ -327,7 +327,7 @@ joinMaxs (MMSPMaxs a₁ α₁) (MMSPMaxs a₂ α₂) = MMSPMaxs (a₁ ⊔ a₂) -- └─────┘ meetMaxs ∷ MMSPMaxs → MMSPMaxs → MMSPMaxs -- (a₁ ∧̇ α₁) ∧̃ (a₂ ∧̇ α₂) ≜ (a₁ ⊓ a₂) ∨̇ ((a₁ ∧̃ α₂) ∨̃ (a₂ ∧̃ α₁) ∨̃ (α₁ ∧̃ α₂)) -meetMaxs (MMSPMaxs a₁ α₁) (MMSPMaxs a₂ α₂) = +meetMaxs (MMSPMaxs a₁ α₁) (MMSPMaxs a₂ α₂) = MMSPMaxs (a₁ + a₂) $ fold zeroMaxsMins joinMaxsMins [ cmeetMaxsMins (AddTop a₁) α₂ , cmeetMaxsMins (AddTop a₂) α₂ @@ -339,7 +339,7 @@ meetMaxs (MMSPMaxs a₁ α₁) (MMSPMaxs a₂ α₂) = -- └─────┘ plusMaxs ∷ MMSPMaxs → MMSPMaxs → MMSPMaxs -- (a₁ ∧̇ α₁) +̃ (a₂ ∧̇ α₂) ≜ (a₁ + a₂) ∨̇ ((a₁ +̃ α₂) ∨̃ (a₂ +̃ α₁) ∨̃ (α₁ +̃ α₂)) -plusMaxs (MMSPMaxs a₁ α₁) (MMSPMaxs a₂ α₂) = +plusMaxs (MMSPMaxs a₁ α₁) (MMSPMaxs a₂ α₂) = MMSPMaxs (a₁ + a₂) $ fold zeroMaxsMins plusMaxsMins [ cplusMaxsMins a₁ α₂ , cplusMaxsMins a₂ α₂ @@ -351,7 +351,7 @@ plusMaxs (MMSPMaxs a₁ α₁) (MMSPMaxs a₂ α₂) = -- └─────┘ timesMaxs ∷ MMSPMaxs → MMSPMaxs → MMSPMaxs -- (a₁ ∧̇ α₁) ×̃ (a₂ ∧̇ α₂) ≜ (a₁ × a₂) ∨̇ ((a₁ ×̃ α₂) ∨̃ (a₂ ×̃ α₁) ∨̃ (α₁̇ ×̃ α₂)) -timesMaxs (MMSPMaxs a₁ α₁) (MMSPMaxs a₂ α₂) = +timesMaxs (MMSPMaxs a₁ α₁) (MMSPMaxs a₂ α₂) = MMSPMaxs (a₁ + a₂) $ fold zeroMaxsMins timesMaxsMins [ ctimesMaxsMins a₁ α₂ , ctimesMaxsMins a₂ α₂ @@ -384,7 +384,7 @@ meetMinsSums xs ys = xs ∪ ys -- │c +̃ β│ -- └─────┘ cplusMinsSums ∷ ℕ → 𝑃 MMSPSums → 𝑃 MMSPSums --- c +̃ β = c + ⨅{ γ | γ ∈ β} +-- c +̃ β = c + ⨅{ γ | γ ∈ β} -- ≜ ⨅ { c +̃ γ | γ ∈ β} cplusMinsSums c = pow ∘ map (cplusSums c) ∘ iter @@ -400,7 +400,7 @@ plusMinsSums β₁ β₂ = pow $ mapOn (iter β₁ ⧆ iter β₂) $ \ (γ₁ :* -- │d ×̃ β│ -- └─────┘ ctimesMinsSums ∷ ℕ → 𝑃 MMSPSums → 𝑃 MMSPSums --- d ×̃ β = d × ⨅{ γ | γ ∈ β} +-- d ×̃ β = d × ⨅{ γ | γ ∈ β} -- ≜ ⨅ { d ×̃ γ | γ ∈ β} ctimesMinsSums c = pow ∘ map (cplusSums c) ∘ iter @@ -440,7 +440,7 @@ cplusMins c (MMSPMins b β) = MMSPMins (map (+ c) b) $ cplusMinsSums c β -- └─────┘ plusMins ∷ MMSPMins → MMSPMins → MMSPMins -- (b₁ ∧̇ β₁) +̃ (b₂ ∧̇ β₂) ≜ (b₁ + b₂) ∧̇ ((b₁ +̃ β₂) ∧̃ (b₂ +̃ β₁) ∧̃ (β₁̇ +̃ β₂)) -plusMins (MMSPMins b₁ β₁) (MMSPMins b₂ β₂) = +plusMins (MMSPMins b₁ β₁) (MMSPMins b₂ β₂) = MMSPMins (b₁ + b₂) $ fold infMinsSums meetMinsSums [ flip (elimAddTop null) b₁ $ \ b₁' → cplusMinsSums b₁' β₂ , flip (elimAddTop null) b₂ $ \ b₂' → cplusMinsSums b₂' β₂ @@ -459,7 +459,7 @@ ctimesMins c (MMSPMins b β) = MMSPMins (AddTop c × b) $ ctimesMinsSums c β -- └─────┘ timesMins ∷ MMSPMins → MMSPMins → MMSPMins -- (b₁ ∧̇ β₁) ×̃ (b₂ ∧̇ β₂) ≜ (b₁ × b₂) ∧̇ ((b₁ ×̃ β₂) ∧̃ (b₂ ×̃ β₁) ∧̃ (β₁̇ ×̃ β₂)) -timesMins (MMSPMins b₁ β₁) (MMSPMins b₂ β₂) = +timesMins (MMSPMins b₁ β₁) (MMSPMins b₂ β₂) = MMSPMins (b₁ × b₂) $ fold infMinsSums meetMinsSums [ flip (elimAddTop null) b₁ $ \ b₁' → ctimesMinsSums b₁' β₂ , flip (elimAddTop null) b₂ $ \ b₂' → ctimesMinsSums b₂' β₂ @@ -503,7 +503,7 @@ ctimesSumsProds d γ = map (× d) γ timesSumsProds ∷ MMSPProds ⇰ ℕ → MMSPProds ⇰ ℕ → MMSPProds ⇰ ℕ -- γ₁ ×̃ γ₂ = ∑{ d×̇δ | d×̇δ ∈ γ₁} × ∑{ d×̇δ | d×̇δ ∈ γ₂ } -- ≜ ∑{ d₁d₂×̇(δ₁×̃δ₂) | d₁×̇δ₁ ∈ γ₁ , d₂×̇δ₂ ∈ γ₂ } -timesSumsProds γ₁ γ₂ = assoc $ mapOn (iter γ₁ ⧆ iter γ₂) $ \ ((δ₁ :* d₁) :* (δ₂ :* d₂)) → +timesSumsProds γ₁ γ₂ = assoc $ mapOn (iter γ₁ ⧆ iter γ₂) $ \ ((δ₁ :* d₁) :* (δ₂ :* d₂)) → timesProds δ₁ δ₂ :* (d₁ × d₂) -- Sums -- diff --git a/src/UVMHS/Lib/Options.hs b/src/UVMHS/Lib/Options.hs index f96145a0..dfd7d2b9 100644 --- a/src/UVMHS/Lib/Options.hs +++ b/src/UVMHS/Lib/Options.hs @@ -1,4 +1,4 @@ -module UVMHS.Lib.Options +module UVMHS.Lib.Options ( module UVMHS.Lib.Options , module System.Console.GetOpt ) where @@ -25,6 +25,6 @@ optUsageInfo ∷ 𝕊 → 𝐿 (OptDescr a) → 𝕊 optUsageInfo s ds = string $ Opt.usageInfo (tohsChars s) $ tohs ds parseOptions ∷ 𝐿 (OptDescr a) → 𝐿 𝕊 → (𝐿 a ∧ 𝐿 𝕊 ∧ 𝐿 𝕊) -parseOptions opts args = +parseOptions opts args = mapPair (mapSnd $ map string) (map string) $ frhs $ Opt.getOpt Opt.RequireOrder (tohs opts) $ tohs $ map tohsChars args diff --git a/src/UVMHS/Lib/Parser/CParser.hs b/src/UVMHS/Lib/Parser/CParser.hs index 2793ae6c..a17035f6 100644 --- a/src/UVMHS/Lib/Parser/CParser.hs +++ b/src/UVMHS/Lib/Parser/CParser.hs @@ -23,7 +23,7 @@ toCParser ∷ Parser t a → CParser t a toCParser p = CParser dø𝐷 p frCParser ∷ (Ord t) ⇒ CParser t a → Parser t a -frCParser (CParser n b) +frCParser (CParser n b) | isEmpty n = b | otherwise = tries [ do t ← pPluck @@ -35,14 +35,14 @@ frCParser (CParser n b) , b ] -instance Return (CParser t) where +instance Return (CParser t) where return ∷ ∀ a. a → CParser t a return x = toCParser $ return x instance (Ord t) ⇒ Bind (CParser t) where (≫=) ∷ ∀ a b. CParser t a → (a → CParser t b) → CParser t b - CParser n b ≫= k = - CParser (map (extend k) n) - (b ≫= frCParser ∘ k) + CParser n b ≫= k = + CParser (map (extend k) n) + (b ≫= frCParser ∘ k) instance (Ord t) ⇒ Functor (CParser t) where map = mmap instance (Ord t) ⇒ Monad (CParser t) @@ -84,7 +84,7 @@ cpShaped ∷ (t → 𝑂 a) → CParser t a cpShaped = toCParser ∘ pShaped cpSatisfies ∷ (t → 𝔹) → CParser t t -cpSatisfies = toCParser ∘ pSatisfies +cpSatisfies = toCParser ∘ pSatisfies cpAny ∷ CParser t t cpAny = toCParser pAny @@ -222,7 +222,7 @@ cpOneOrMoreSepByContext f sepM xM = do --------------------- -- Running Parsers -- --------------------- - + runParser₀ ∷ (ToIter (ParserToken t) ts,Ord t) ⇒ 𝕊 → ts → CParser t a → ParserOut t ∧ 𝑂 (ParserState t ∧ a) runParser₀ so = (∘ frCParser) ∘ runParser (parserEnv₀ so) ∘ parserState₀ ∘ stream @@ -239,7 +239,7 @@ parseIO p s ts = case parse p s ts of parseIOMain ∷ (Pretty a,ToIter (ParserToken t) ts,Ord t) ⇒ CParser t a → 𝕊 → ts → IO () parseIOMain p s ts = do x ← parseIO p s ts - pprint $ ppVertical + pprint $ ppVertical [ ppHeader "Success" , pretty x ] diff --git a/src/UVMHS/Lib/Parser/Core.hs b/src/UVMHS/Lib/Parser/Core.hs index e399ae46..6e844648 100644 --- a/src/UVMHS/Lib/Parser/Core.hs +++ b/src/UVMHS/Lib/Parser/Core.hs @@ -53,8 +53,8 @@ parserState₀ = ParserState null null null null $ AddBT bot -- # Parser -newtype Parser t a = Parser { unParser ∷ ReaderT ParserEnv (StateT (ParserState t) (FailT ((∧) (ParserOut t)))) a } - deriving +newtype Parser t a = Parser { unParser ∷ ReaderT ParserEnv (StateT (ParserState t) (FailT ((∧) (ParserOut t)))) a } + deriving ( Functor,Return,Bind,Monad , MonadFail , MonadReader ParserEnv @@ -97,7 +97,7 @@ pGetContext = do pc ← getL parserStateContextL ps ← getL parserStateSuffixL return $ (pp ⧺ parserContextDisplayR pk) :* pc :* ps - + pGetContextRendered ∷ Parser t SrcCxt pGetContextRendered = do pp :* pc :* ps ← pGetContext @@ -170,7 +170,7 @@ pPluck = do pRecord ∷ ParserToken t → Parser t () pRecord t = do modifyL parserStateContextL $ \ c → c ⧺ parserTokenContext t - putL parserStateSuffixL $ parserTokenSuffix t + putL parserStateSuffixL $ parserTokenSuffix t pEnd ∷ Parser t () pEnd = do @@ -206,7 +206,7 @@ pShaped {- msg -} sh = do pSatisfies ∷ {- 𝕊 → -} (t → 𝔹) → Parser t t pSatisfies {- msg -} p = pShaped {- msg -} $ \ x → case p x of - True → Some x + True → Some x False → None pDie ∷ {- 𝕊 → -} Parser t a diff --git a/src/UVMHS/Lib/Parser/Examples.hs b/src/UVMHS/Lib/Parser/Examples.hs index 306bdb11..f999a444 100644 --- a/src/UVMHS/Lib/Parser/Examples.hs +++ b/src/UVMHS/Lib/Parser/Examples.hs @@ -43,35 +43,35 @@ testParsingBranching = parseIOMain parser "" input ] input ∷ 𝕍 (ParserToken ℂ) input = tokens "xxxx" - + -- testParsingAmbiguity ∷ IO () -- testParsingAmbiguity = parseIOMain parser input -- where --- parser = concat ^$ pOneOrMore $ tries +-- parser = concat ^$ pOneOrMore $ tries -- [ ppFG yellow ∘ ppString ∘ single ^$ pToken 'y' -- , ppFG green ∘ ppString ∘ single ^$ pToken 'x' --- , ppFG blue ∘ ppString ^$ pWord "xx" +-- , ppFG blue ∘ ppString ^$ pWord "xx" -- ] -- input = tokens "xxx" testParsingGreedy ∷ IO () testParsingGreedy = parseIOMain parser "" input where - parser = concat ^$ cpOneOrMore $ tries + parser = concat ^$ cpOneOrMore $ tries [ ppFG yellow ∘ ppString ∘ single ^$ cpRender (formats [FG yellow]) $ toCParser $ pToken 'y' , ppFG green ∘ ppString ∘ single ^$ cpRender (formats [FG green]) $ toCParser $ pToken 'x' - , ppFG blue ∘ ppString ^$ cpRender (formats [FG yellow]) $ cpWord "xx" + , ppFG blue ∘ ppString ^$ cpRender (formats [FG yellow]) $ cpWord "xx" ] input = tokens "xxx" testParsingGreedyAmbiguity ∷ IO () testParsingGreedyAmbiguity = parseIOMain parser "" input where - parser = concat ^$ cpOneOrMore $ tries + parser = concat ^$ cpOneOrMore $ tries [ ppFG yellow ∘ ppString ∘ single ^$ cpRender (formats [FG yellow]) $ toCParser $ pToken 'y' , tries - [ ppFG blue ∘ ppString ^$ cpRender (formats [FG blue]) $ cpWord "x" - , ppFG pink ∘ ppString ^$ cpRender (formats [FG pink]) $ cpWord "xx" + [ ppFG blue ∘ ppString ^$ cpRender (formats [FG blue]) $ cpWord "x" + , ppFG pink ∘ ppString ^$ cpRender (formats [FG pink]) $ cpWord "xx" ] , ppFG green ∘ ppString ∘ single ^$ cpRender (formats [FG green]) $ toCParser $ pToken 'x' ] @@ -80,7 +80,7 @@ testParsingGreedyAmbiguity = parseIOMain parser "" inp testParsingSuccess ∷ IO () testParsingSuccess = parseIOMain parser "" input where - parser = concat ^$ cpOneOrMore $ tries + parser = concat ^$ cpOneOrMore $ tries [ cpRender (formats [FG green]) $ cpWord $ 𝕤 "xx" , cpRender (formats [FG blue]) $ cpWord $ 𝕤 "yy" ] @@ -93,19 +93,19 @@ testParsingErrorEof ∷ IO () testParsingErrorEof = parseIOMain (exec $ replicate (𝕟 3) $ void $ cpToken 'x') "" $ tokens "xx" testTokenizeSimple ∷ IO () -testTokenizeSimple = +testTokenizeSimple = let rgx = lWord "x" ▷ oepsRegex () dfa = compileRegex rgx in tokenizeIOMain (Lexer (const dfa) (const ∘ ((:*) False) ∘ string) ()) "" $ tokens "xxx" testTokenize ∷ IO () -testTokenize = +testTokenize = let rgx = concat [lWord "x",lWord "xy",lWord "y"] ▷ oepsRegex () dfa = compileRegex rgx in tokenizeIOMain (Lexer (const dfa) (const ∘ ((:*) False) ∘ string) ()) "" $ tokens "xxyxyxyxyxxyy" testTokenizeFailure1 ∷ IO () -testTokenizeFailure1 = +testTokenizeFailure1 = let rgx = concat [ lWord "x" ▷ fepsRegex (formats [FG green]) ▷ lepsRegex (𝕟64 2) , lWord "x" ▷ fepsRegex (formats [FG yellow]) ▷ lepsRegex (𝕟64 1) @@ -117,7 +117,7 @@ testTokenizeFailure1 = in tokenizeIOMain (Lexer (const dfa) (const ∘ ((:*) False) ∘ string) ()) "" $ tokens "xxxxy" testTokenizeFailure2 ∷ IO () -testTokenizeFailure2 = +testTokenizeFailure2 = let rgx = concat [ lWord "x" ▷ fepsRegex (formats [FG green]) ▷ lepsRegex (𝕟64 2) , lWord "x" ▷ fepsRegex (formats [FG yellow]) ▷ lepsRegex (𝕟64 1) diff --git a/src/UVMHS/Lib/Parser/Mixfix.hs b/src/UVMHS/Lib/Parser/Mixfix.hs index 1ae7f08d..c45813d0 100644 --- a/src/UVMHS/Lib/Parser/Mixfix.hs +++ b/src/UVMHS/Lib/Parser/Mixfix.hs @@ -60,7 +60,7 @@ data MixesF t f a = MixesF instance Null (MixesF t f a) where null = MixesF null null null null null instance (Ord t) ⇒ Append (MixesF t f a) where - MixesF pre₁ post₁ inf₁ infl₁ infr₁ ⧺ MixesF pre₂ post₂ inf₂ infl₂ infr₂ = + MixesF pre₁ post₁ inf₁ infl₁ infr₁ ⧺ MixesF pre₂ post₂ inf₂ infl₂ infr₂ = MixesF (pre₁ ⧺ pre₂) (post₁ ⧺ post₂) (inf₁ ⧺ inf₂) (infl₁ ⧺ infl₂) $ infr₁ ⧺ infr₂ instance (Ord t) ⇒ Monoid (MixesF t f a) @@ -96,17 +96,17 @@ fmixTerminal p = null { mixfixFTerminals = p} -- PRE PRE x INFR PRE PRE y -- ≈ -- PRE (PRE (x INFR (PRE (PRE y)))) --- +-- -- x POST POST INFL y POST POST -- ≈ -- ((((x POST) POST) INFL y) POST) POST -fmixfix ∷ +fmixfix ∷ ∀ t f a. (Ord t,Comonad f) - ⇒ (CParser t (f a) → CParser t (f a)) - → (CParser t (f a) → CParser t (f a)) - → (CParser t a → CParser t (f a)) - → MixfixF t f a + ⇒ (CParser t (f a) → CParser t (f a)) + → (CParser t (f a) → CParser t (f a)) + → (CParser t a → CParser t (f a)) + → MixfixF t f a → CParser t (f a) fmixfix new bracket cxt (MixfixF terms levels₀) = loop levels₀ where @@ -115,9 +115,9 @@ fmixfix new bracket cxt (MixfixF terms levels₀) = loop levels₀ None → new $ cxt terms Some ((i :* mixes) :* levels') → let msg = "lvl " ⧺ alignRightFill '0' 3 (show𝕊 i) - in - new $ cxt $ buildLevelDirected msg mixes $ - new $ cxt $ buildLevelNondirected msg mixes $ + in + new $ cxt $ buildLevelDirected msg mixes $ + new $ cxt $ buildLevelNondirected msg mixes $ loop levels' buildLevelNondirected ∷ 𝕊 → MixesF t f a → CParser t (f a) → CParser t a buildLevelNondirected msg mixes nextLevel = do @@ -191,12 +191,12 @@ data Mixes t a = Mixes } instance Null (Mixes t a) where null = Mixes null null null null null -instance (Ord t) ⇒ Append (Mixes t a) where - Mixes pre₁ post₁ inf₁ infl₁ infr₁ ⧺ Mixes pre₂ post₂ inf₂ infl₂ infr₂ = +instance (Ord t) ⇒ Append (Mixes t a) where + Mixes pre₁ post₁ inf₁ infl₁ infr₁ ⧺ Mixes pre₂ post₂ inf₂ infl₂ infr₂ = Mixes (pre₁ ⧺ pre₂) (post₁ ⧺ post₂) (inf₁ ⧺ inf₂) (infl₁ ⧺ infl₂) (infr₁ ⧺ infr₂) instance (Ord t) ⇒ Monoid (Mixes t a) -data Mixfix t a = Mixfix +data Mixfix t a = Mixfix { mixfixTerminals ∷ CParser t a , mixfixLevels ∷ ℕ64 ⇰ Mixes t a } @@ -236,7 +236,7 @@ mixfixPure ∷ (Ord t) ⇒ Mixfix t a → MixfixF t ID a mixfixPure (Mixfix terminals levels) = MixfixF terminals $ map mixesPure levels mixfix ∷ (Ord t) ⇒ Mixfix t a → CParser t a -mixfix mix = unID ^$ fmixfix id id (map ID) (mixfixPure mix) +mixfix mix = unID ^$ fmixfix id id (map ID) (mixfixPure mix) mixfixWithContext ∷ (Ord t) ⇒ 𝕊 → Mixfix t a → CParser t (𝐴 SrcCxt a) mixfixWithContext s = cpNewContext s ∘ cpWithContextRendered ∘ mixfix diff --git a/src/UVMHS/Lib/Parser/ParserContext.hs b/src/UVMHS/Lib/Parser/ParserContext.hs index c935dd5e..28606510 100644 --- a/src/UVMHS/Lib/Parser/ParserContext.hs +++ b/src/UVMHS/Lib/Parser/ParserContext.hs @@ -16,9 +16,9 @@ data ParserContext = ParserContext makeLenses ''ParserContext makePrettySum ''ParserContext -instance Null ParserContext where +instance Null ParserContext where null = ParserContext bot null null null -instance Append ParserContext where +instance Append ParserContext where ParserContext l₁ dL₁ dR₁ e₁ ⧺ ParserContext l₂ dL₂ dR₂ e₂ = ParserContext (l₁ ⊔ l₂) (dL₁ ⧺ dL₂) (dR₁ ⧺ dR₂) $ e₁ ⧺ e₂ instance Monoid ParserContext @@ -47,7 +47,7 @@ instance Pretty SrcCxt where , concat [ ppAnnotation $ ppString "«" , ppAlign $ concat - [ renderWindowR pre + [ renderWindowR pre , ppUT '^' green $ renderWindowL d , renderWindowL pi ] @@ -63,7 +63,7 @@ instance Pretty SrcCxt where , ppPun ":" , pretty $ succ c ] - + instance Show SrcCxt where show = tohsChars ∘ ppshow diff --git a/src/UVMHS/Lib/Parser/ParserError.hs b/src/UVMHS/Lib/Parser/ParserError.hs index c96cf41a..8cef3549 100644 --- a/src/UVMHS/Lib/Parser/ParserError.hs +++ b/src/UVMHS/Lib/Parser/ParserError.hs @@ -28,7 +28,7 @@ instance Append (ParserError t) where EQ → ParserError l₁ d₁ s₁ $ f₁ ⧺ f₂ GT → e₁ -data ParserErrorStackTraces = ParserErrorStackTraces +data ParserErrorStackTraces = ParserErrorStackTraces { parserErrorStackTracesMessages ∷ 𝑃 𝕊 , parserErrorStackTracesChain ∷ 𝕊 ⇰ ParserErrorStackTraces } deriving (Eq, Ord) @@ -42,13 +42,13 @@ instance Join ParserErrorStackTraces where instance JoinLattice ParserErrorStackTraces stackTraces ∷ 𝕊 → 𝐼 𝕊 → ParserErrorStackTraces -stackTraces fin msgs = foldrOnFrom msgs (ParserErrorStackTraces (single fin) bot) $ \ msg tr → +stackTraces fin msgs = foldrOnFrom msgs (ParserErrorStackTraces (single fin) bot) $ \ msg tr → ParserErrorStackTraces bot $ msg ↦ tr parserErrorFailuresMap ∷ 𝐼 ParserErrorInfo → (𝕊 ∧ 𝔹) ⇰ WindowR Doc Doc ∧ WindowR Doc Doc ∧ ParserErrorStackTraces -parserErrorFailuresMap eis = - fold bot (dunionBy $ \ (c' :* p' :* t₁) (_ :* _ :* t₂) → c' :* p' :* (t₁ ⊔ t₂)) $ - mapOn eis $ \ (ParserErrorInfo p c sh st) → +parserErrorFailuresMap eis = + fold bot (dunionBy $ \ (c' :* p' :* t₁) (_ :* _ :* t₂) → c' :* p' :* (t₁ ⊔ t₂)) $ + mapOn eis $ \ (ParserErrorInfo p c sh st) → (ppRender (concat c) :* overflowR c) ↦ (p :* c :* stackTraces sh st) displaySourceError ∷ 𝕊 → AddNull (ParserError t) → Doc @@ -59,20 +59,20 @@ displaySourceError so peM = ppVertical $ concat , case peM of Null → return $ ppErr "> No Reported Errors" AddNull (ParserError l tc ts fs) → concat - [ return $ ppHorizontal + [ return $ ppHorizontal [ ppErr ">" - , concat + , concat [ ppString "line:" , pretty $ succ ∘ locRow ^$ l ] - , concat + , concat [ ppString "column:" , pretty $ succ ∘ locCol ^$ l ] ] , return $ ppHeader "One of:" , inbetween (ppHeader "OR") $ mapOn (map snd $ iter $ parserErrorFailuresMap fs) $ \ (pp :* pc :* ets) → - ppVertical + ppVertical [ concat [ renderWindowR pp , ppUT '^' green $ renderWindowR pc @@ -87,7 +87,7 @@ displaySourceError so peM = ppVertical $ concat displayErrorTraces ∷ ParserErrorStackTraces → Doc displayErrorTraces (ParserErrorStackTraces final chain) = ppVertical $ concat [ case isEmpty final of - True → null + True → null False → return $ ppHorizontal $ concat [ single $ ppFG red $ ppString "Expected" , inbetween (ppFG red $ ppString "OR") $ map ppString $ iter final @@ -99,4 +99,4 @@ displayErrorTraces (ParserErrorStackTraces final chain) = ppVertical $ concat ] , concat [ppSpace $ 𝕟64 2,ppAlign $ displayErrorTraces tr] ] - ] + ] diff --git a/src/UVMHS/Lib/Parser/ParserInput.hs b/src/UVMHS/Lib/Parser/ParserInput.hs index 1611a3a0..59886199 100644 --- a/src/UVMHS/Lib/Parser/ParserInput.hs +++ b/src/UVMHS/Lib/Parser/ParserInput.hs @@ -40,7 +40,7 @@ renderEOFError ∷ Doc renderEOFError = ppErr "EOF" eofContext ∷ AddBT Loc → ParserContext -eofContext l = +eofContext l = let lr = LocRange l l in ParserContext lr (eWindowL renderEOFDisplay) (eWindowR renderEOFDisplay) $ eWindowR renderEOFError @@ -56,9 +56,9 @@ charContext l c = in ParserContext lr (eWindowL d) (eWindowR d) $ eWindowR d preTokens ∷ 𝕊 → 𝕍 (PreParserToken ℂ) -preTokens cs = +preTokens cs = vecC $ snd $ foldOnFrom cs (bot :* null @(𝐼C _)) $ \ c (loc :* ts) → - let (loc',pc) = + let (loc',pc) = if c ≡ '\n' then (bumpRow₁ loc,nlContext loc) else (bumpCol₁ loc,charContext loc c) diff --git a/src/UVMHS/Lib/Parser/Regex.hs b/src/UVMHS/Lib/Parser/Regex.hs index 69c85323..566b4675 100644 --- a/src/UVMHS/Lib/Parser/Regex.hs +++ b/src/UVMHS/Lib/Parser/Regex.hs @@ -37,7 +37,7 @@ instance (Ord u,Zero u) ⇒ Monoid (RegexResult o u) instance (Zero u) ⇒ Eps (RegexResult o u) where eps = RegexResult zero null None zero instance (Ord u,Plus u) ⇒ Seq (RegexResult o u) where - RegexResult l₁ fm₁ o₁ u₁ ▷ RegexResult l₂ fm₂ o₂ u₂ = + RegexResult l₁ fm₁ o₁ u₁ ▷ RegexResult l₂ fm₂ o₂ u₂ = RegexResult (l₁ ⩏ l₂) (fm₁ ⧺ fm₂) (first o₁ o₂) (u₁ + u₂) instance (Ord u,Additive u) ⇒ Seqoid (RegexResult o u) @@ -50,9 +50,9 @@ newtype RegexInfo o u = RegexInfo } deriving (Eq,Ord,Show) makePrettySum ''RegexInfo -instance (Zero u) ⇒ Null (RegexInfo o u) where +instance (Zero u) ⇒ Null (RegexInfo o u) where null = RegexInfo None -instance (Ord u) ⇒ Append (RegexInfo o u) where +instance (Ord u) ⇒ Append (RegexInfo o u) where RegexInfo rO₁ ⧺ RegexInfo rO₂ = RegexInfo $ case (rO₁,rO₂) of (None,None) → None (None,Some r₂) → Some r₂ @@ -164,7 +164,7 @@ snocEpsRegexU r = \case AtomR r' a → AtomR (r' ▷ r) a SumsR es → SumsR $ pow $ map (consEpsRegex r) $ iter es SeqsR Nil → NullR - SeqsR (e :& es) → + SeqsR (e :& es) → let (es' :* e') = swivelR e es e'' = snocEpsRegex r e' (e''' :* es'') = swivelL es' e'' @@ -180,7 +180,7 @@ sumRegex e₁@(Regex (𝐴 i₁ e₁')) e₂@(Regex (𝐴 i₂ e₂')) = Regex $ (SumsR es₁,_) → SumsR $ es₁ ∪ single e₂ (_,SumsR es₂) → SumsR $ single e₁ ∪ es₂ _ → SumsR $ pow [e₁,e₂] - + seqRegex ∷ (Ord c,Ord t,Ord o,Ord u,Additive u) ⇒ Regex c t o u → Regex c t o u → Regex c t o u seqRegex e₁@(Regex (𝐴 i₁ e₁')) e₂@(Regex (𝐴 i₂ e₂')) = Regex $ 𝐴 (i₁ ▷ i₂) $ case (e₁',e₂') of (NullR,_) → NullR @@ -215,7 +215,7 @@ derRegex xc e₀ = case extract $ unRegex e₀ of derRegexAtom ∷ (Ord c,Ord t,Classified c t,Ord o,Ord u,Additive u) ⇒ t ∨ c → RegexAtom c t o u → Regex c t o u derRegexAtom xc = \case TokRA t → case xc of - Inl t' + Inl t' | t ≡ t' → eps | otherwise → null Inr _ → null @@ -242,7 +242,7 @@ derRegexSequence xc (e@(Regex (𝐴 i _)) :& es) = case regexInfoResult i of ] -- Literals -- - + regexLits ∷ (Ord t) ⇒ Regex c t o u → 𝑃 t regexLits e₀ = case extract $ unRegex e₀ of NullR → pø @@ -287,7 +287,7 @@ compileRegex ∷ ∀ c t o u. (Pretty t,Pretty o,Pretty u,Ord c,Ord t,Classified compileRegex e₀ = let RegexState _ _ tr re de :* n = runState regexState₀ $ compile e₀ in DFA lits n (map vecDΩ tr) (vecDΩ re) $ vecDΩ de - where + where lits ∷ 𝑃 t lits = regexLits e₀ codes ∷ 𝑃 (t ∨ c) @@ -326,8 +326,8 @@ data Lexer c t o u w = Lexer , lexerInitState ∷ u } -tokenize ∷ - ∀ c t o u w. (Show u,Ord c,Ord t,Pretty t,Classified c t,Eq o,Eq u,Plus u) +tokenize ∷ + ∀ c t o u w. (Show u,Ord c,Ord t,Pretty t,Classified c t,Eq o,Eq u,Plus u) ⇒ Lexer c t o u w → 𝕊 → 𝕍 (ParserToken t) → Doc ∨ 𝕍 (PreParserToken w) tokenize (Lexer dfas f u₀) so ts₀ = vecC ^$ oloop u₀ (dfas u₀) null $ stream ts₀ where @@ -398,30 +398,30 @@ tokenize (Lexer dfas f u₀) so ts₀ = vecC ^$ oloop u₀ (dfas u₀) null $ st iloop n' σ' (Some (t :* σ)) rO' tokenizeFIO ∷ - ∀ c t o u w w'. (Show u,Ord c,Ord t,Pretty t,Classified c t,Eq o,Eq u,Plus u) + ∀ c t o u w w'. (Show u,Ord c,Ord t,Pretty t,Classified c t,Eq o,Eq u,Plus u) ⇒ Lexer c t o u w → 𝕊 → (𝕍 (PreParserToken w) → 𝕍 (PreParserToken w')) → 𝕍 (ParserToken t) → IO (𝕍 (ParserToken w')) tokenizeFIO l so f pi = case map f $ tokenize l so pi of Inl d → pprint d ≫ abortIO Inr xs → return $ finalizeTokens xs -tokenizeIO ∷ - ∀ c t o u w. (Show u,Ord c,Ord t,Pretty t,Classified c t,Eq o,Eq u,Plus u) +tokenizeIO ∷ + ∀ c t o u w. (Show u,Ord c,Ord t,Pretty t,Classified c t,Eq o,Eq u,Plus u) ⇒ Lexer c t o u w → 𝕊 → 𝕍 (ParserToken t) → IO (𝕍 (ParserToken w)) tokenizeIO l so = tokenizeFIO l so id -tokenizeFIOMain ∷ - ∀ c t o u w w'. (Show u,Ord c,Ord t,Pretty t,Classified c t,Eq o,Eq u,Plus u,Pretty w') +tokenizeFIOMain ∷ + ∀ c t o u w w'. (Show u,Ord c,Ord t,Pretty t,Classified c t,Eq o,Eq u,Plus u,Pretty w') ⇒ Lexer c t o u w → 𝕊 → (𝕍 (PreParserToken w) → 𝕍 (PreParserToken w')) → 𝕍 (ParserToken t) → IO () tokenizeFIOMain l so f pi = do xs ← tokenizeFIO l so f pi - pprint $ ppVertical + pprint $ ppVertical [ ppHeader "Success" , pretty $ mapOn xs $ \ x → parserTokenValue x :* parserContextLocRange (parserTokenContext x) ] pprint $ concat $ map (concat ∘ iter ∘ parserContextDisplayL ∘ parserTokenContext) xs tokenizeIOMain ∷ - ∀ c t o u w. (Show u,Ord c,Ord t,Pretty t,Classified c t,Eq o,Eq u,Plus u,Pretty w) + ∀ c t o u w. (Show u,Ord c,Ord t,Pretty t,Classified c t,Eq o,Eq u,Plus u,Pretty w) ⇒ Lexer c t o u w → 𝕊 → 𝕍 (ParserToken t) → IO () tokenizeIOMain l so = tokenizeFIOMain l so id @@ -454,7 +454,7 @@ lNl ∷ (Zero u,Ord o,Ord u,Additive u) ⇒ Regex CharClass ℂ o u lNl = oom $ classRegex NewlineClass lName ∷ (Zero u,Ord u,Ord o,Additive u) ⇒ Regex CharClass ℂ o u -lName = +lName = let begTok = concat [ classRegex LetterClass , concat $ map tokRegex $ iter $ 𝕤 "_'′″‴" @@ -464,7 +464,7 @@ lName = , classRegex NumberClass ] midTok = begTok ⧺ endTok ⧺ tokRegex '-' - in + in sequence [ begTok , opt $ sequence @@ -546,7 +546,7 @@ lComment = sequence lCommentMLOpen ∷ (Ord o) ⇒ Regex CharClass ℂ o ℕ64 lCommentMLOpen = sequence - [ lWord "{-" + [ lWord "{-" , uepsRegex one , fepsRegex $ formats [IT,FG grayLight] , lepsRegex $ 𝕟64 100 @@ -706,42 +706,42 @@ blockifyTokens anchors₀ isNewline isBlock mkIndentToken ts₀ = vecC $ loop nu prefixLocRangeBumpedEnd = locRangeEnd prefixLocRangeBumped in if - | preParserTokenSkip t → - loopUnanchored (prefix ⧺ single t) - (prefixLocRangeBumped ⊔ bumpColEnd₂ (parserContextLocRange $ preParserTokenContext t)) - isFreshBlock + | preParserTokenSkip t → + loopUnanchored (prefix ⧺ single t) + (prefixLocRangeBumped ⊔ bumpColEnd₂ (parserContextLocRange $ preParserTokenContext t)) + isFreshBlock ts' - | {- not (parserTokenSkip t) ⩓ -} + | {- not (parserTokenSkip t) ⩓ -} isFreshBlock → concat - -- + -- -- ... -- ^^^^^^^ [ prefix , single $ syntheticToken prefixLocRangeBumpedEnd OpenIC , single t - , loopAnchored null - (LocRange prefixLocRangeBumpedEnd prefixLocRangeBumpedEnd) - (isBlock $ preParserTokenValue t) - False - locₜ - null + , loopAnchored null + (LocRange prefixLocRangeBumpedEnd prefixLocRangeBumpedEnd) + (isBlock $ preParserTokenValue t) + False + locₜ + null ts' ] - | {- not (parserTokenSkip t) ⩓ not (isFreshBlock t) ⩓ -} + | {- not (parserTokenSkip t) ⩓ not (isFreshBlock t) ⩓ -} otherwise → concat -- -- ... -- ^^^^^^^ [ prefix , single t - , loopUnanchored null - (LocRange prefixLocRangeBumpedEnd prefixLocRangeBumpedEnd) - (isBlock $ preParserTokenValue t) + , loopUnanchored null + (LocRange prefixLocRangeBumpedEnd prefixLocRangeBumpedEnd) + (isBlock $ preParserTokenValue t) ts' ] loopAnchored ∷ 𝐼C (PreParserToken t) → LocRange → 𝔹 → 𝔹 → AddBT Loc → 𝐿 (AddBT Loc) → 𝑆 (PreParserToken t) → 𝐼C (PreParserToken t) loopAnchored prefix prefixLocRangeBumped isFreshBlock isAfterNewline anchor anchors ts = case un𝑆 ts () of - None → + None → let loop' ∷ 𝐿 (AddBT Loc) → 𝐼C (PreParserToken t) loop' anchors' = if anchors' ≡ anchors₀ @@ -754,25 +754,25 @@ blockifyTokens anchors₀ isNewline isBlock mkIndentToken ts₀ = vecC $ loop nu ] -- () = pptrace $ ppHorizontal [ppBD $ ppString "COUNT",pretty $ count prefix] in concat - [ if isFreshBlock + [ if isFreshBlock then concat - [ single $ syntheticToken (locRangeBegin prefixLocRangeBumped) OpenIC - , single $ syntheticToken (locRangeBegin prefixLocRangeBumped) CloseIC + [ single $ syntheticToken (locRangeBegin prefixLocRangeBumped) OpenIC + , single $ syntheticToken (locRangeBegin prefixLocRangeBumped) CloseIC ] else null - , loop' (anchor :& anchors) + , loop' (anchor :& anchors) , prefix ] - Some (t :* ts') → + Some (t :* ts') → let locₜ = locRangeBegin $ parserContextLocRange $ preParserTokenContext t prefixLocRangeBumpedEnd = locRangeEnd prefixLocRangeBumped prefixLocRangeBumpedBegin = locRangeBegin prefixLocRangeBumped recordTokenKeepGoing ∷ 𝐼C (PreParserToken t) → LocRange → 𝔹 → 𝐼C (PreParserToken t) - recordTokenKeepGoing prefix' prefixLocRangeBumped' weHaveANewAnchor = + recordTokenKeepGoing prefix' prefixLocRangeBumped' weHaveANewAnchor = let prefixLocRangeBumpedEnd' = locRangeEnd prefixLocRangeBumped' - anchor' :* anchors' = - if weHaveANewAnchor + anchor' :* anchors' = + if weHaveANewAnchor -- -- anchor ->| -- ^^^^^^^ @@ -791,27 +791,27 @@ blockifyTokens anchors₀ isNewline isBlock mkIndentToken ts₀ = vecC $ loop nu -- record the token , single t -- keep going with new anchor - , loopAnchored null - (LocRange prefixLocRangeBumpedEnd' prefixLocRangeBumpedEnd') - (isBlock $ preParserTokenValue t) - False - anchor' - anchors' + , loopAnchored null + (LocRange prefixLocRangeBumpedEnd' prefixLocRangeBumpedEnd') + (isBlock $ preParserTokenValue t) + False + anchor' + anchors' ts' ] in - if + if | preParserTokenSkip t → -- this is a skip token; add it to the list - loopAnchored (prefix ⧺ single t) - (prefixLocRangeBumped ⊔ bumpColEnd₂ (parserContextLocRange $ preParserTokenContext t)) - isFreshBlock - (isAfterNewline ⩔ isNewline (preParserTokenValue t)) - anchor - anchors + loopAnchored (prefix ⧺ single t) + (prefixLocRangeBumped ⊔ bumpColEnd₂ (parserContextLocRange $ preParserTokenContext t)) + isFreshBlock + (isAfterNewline ⩔ isNewline (preParserTokenValue t)) + anchor + anchors ts' - | {- not (parserTokenSkip t) ⩓ -} - not isAfterNewline → + | {- not (parserTokenSkip t) ⩓ -} + not isAfterNewline → -- -- anchor ->|... -- ^^^^^^^ @@ -822,7 +822,7 @@ blockifyTokens anchors₀ isNewline isBlock mkIndentToken ts₀ = vecC $ loop nu -- ^^^^^^^ -- continue as normal recordTokenKeepGoing prefix prefixLocRangeBumped isFreshBlock - | {- not (parserTokenSkip t) ⩓ isAfterNewline ⩓ -} + | {- not (parserTokenSkip t) ⩓ isAfterNewline ⩓ -} map locCol locₜ > map locCol anchor → -- -- anchor ->|... @@ -830,7 +830,7 @@ blockifyTokens anchors₀ isNewline isBlock mkIndentToken ts₀ = vecC $ loop nu -- ^^^^^^^ -- continue as normal recordTokenKeepGoing prefix prefixLocRangeBumped isFreshBlock - | {- not (parserTokenSkip t) ⩓ isAfterNewline ⩓ -} + | {- not (parserTokenSkip t) ⩓ isAfterNewline ⩓ -} map locCol locₜ ≡ map locCol anchor → concat -- -- anchor ->|... @@ -838,10 +838,10 @@ blockifyTokens anchors₀ isNewline isBlock mkIndentToken ts₀ = vecC $ loop nu -- ^^^^^^^ -- this is logically a “newline” -- if we just opened a new block, open and close it - [ if isFreshBlock + [ if isFreshBlock then concat - [ single $ syntheticToken prefixLocRangeBumpedBegin OpenIC - , single $ syntheticToken prefixLocRangeBumpedBegin CloseIC + [ single $ syntheticToken prefixLocRangeBumpedBegin OpenIC + , single $ syntheticToken prefixLocRangeBumpedBegin CloseIC ] else null -- record the prefix @@ -851,7 +851,7 @@ blockifyTokens anchors₀ isNewline isBlock mkIndentToken ts₀ = vecC $ loop nu -- keep going , recordTokenKeepGoing null (LocRange prefixLocRangeBumpedEnd prefixLocRangeBumpedEnd) False ] - | {- not (parserTokenSkip t) ⩓ isAfterNewline ⩓ -} + | {- not (parserTokenSkip t) ⩓ isAfterNewline ⩓ -} map locCol locₜ < map locCol anchor → concat -- -- anchor ->|... @@ -859,15 +859,15 @@ blockifyTokens anchors₀ isNewline isBlock mkIndentToken ts₀ = vecC $ loop nu -- ^^^^^^^ -- this is logically a “close” -- if we just opened a new block, close it - [ if isFreshBlock + [ if isFreshBlock then concat - [ single $ syntheticToken prefixLocRangeBumpedBegin OpenIC - , single $ syntheticToken prefixLocRangeBumpedBegin CloseIC + [ single $ syntheticToken prefixLocRangeBumpedBegin OpenIC + , single $ syntheticToken prefixLocRangeBumpedBegin CloseIC ] else null -- record a “close” , single $ syntheticToken prefixLocRangeBumpedBegin CloseIC - -- restart this token with new anchor + -- restart this token with new anchor , loop prefix prefixLocRangeBumped False isAfterNewline anchors ts ] | otherwise → error "impossible" diff --git a/src/UVMHS/Lib/Pipeline.hs b/src/UVMHS/Lib/Pipeline.hs index 3c8154f5..8c7e838b 100644 --- a/src/UVMHS/Lib/Pipeline.hs +++ b/src/UVMHS/Lib/Pipeline.hs @@ -6,7 +6,7 @@ import UVMHS.Core -- definitions uses a GADT to capture chaining `a → m b` with `b → m c` as a -- `Pipeline` from `a` to `c`, and where `b` ends up existentially quantified -- in the chain. --- +-- -- A `Pipeline` 𝒸 m i a b` imposes constraint `𝒸` on all intermediate result -- types of monadic computations in the list, annotates each function in the -- list with a value of type `i`, and ultimately consumes a value of type `a` diff --git a/src/UVMHS/Lib/Pretty.hs b/src/UVMHS/Lib/Pretty.hs index d3596ace..0237862a 100644 --- a/src/UVMHS/Lib/Pretty.hs +++ b/src/UVMHS/Lib/Pretty.hs @@ -1,4 +1,4 @@ -module UVMHS.Lib.Pretty +module UVMHS.Lib.Pretty ( module UVMHS.Lib.Pretty.Annotation , module UVMHS.Lib.Pretty.Color , module UVMHS.Lib.Pretty.Common diff --git a/src/UVMHS/Lib/Pretty/Annotation.hs b/src/UVMHS/Lib/Pretty/Annotation.hs index 825e12d9..a0b61176 100644 --- a/src/UVMHS/Lib/Pretty/Annotation.hs +++ b/src/UVMHS/Lib/Pretty/Annotation.hs @@ -7,7 +7,7 @@ import UVMHS.Lib.Pretty.Color -- Formats -- ------------- -data Format = +data Format = FG Color | NOFG | BG Color @@ -29,7 +29,7 @@ data Formats = Formats } deriving (Eq,Ord,Show) instance Null Formats where null = Formats None None None None None instance Append Formats where - Formats fg₁ bg₁ ul₁ bd₁ it₁ ⧺ Formats fg₂ bg₂ ul₂ bd₂ it₂ = + Formats fg₁ bg₁ ul₁ bd₁ it₁ ⧺ Formats fg₂ bg₂ ul₂ bd₂ it₂ = Formats (first fg₁ fg₂) (first bg₁ bg₂) (first ul₁ ul₂) (first bd₁ bd₂) (first it₁ it₂) instance Monoid Formats diff --git a/src/UVMHS/Lib/Pretty/Color.hs b/src/UVMHS/Lib/Pretty/Color.hs index 2f55ed02..8a818cd0 100644 --- a/src/UVMHS/Lib/Pretty/Color.hs +++ b/src/UVMHS/Lib/Pretty/Color.hs @@ -21,7 +21,7 @@ data Color3Bit = | TealLight | White deriving (Eq,Ord,Show) -data Color = +data Color = Color Color3Bit | Color8 ℕ8 | Color24 ℕ8 ℕ8 ℕ8 @@ -63,7 +63,7 @@ altBlue,altBlueLight,altPurple,altPurpleLight,altTeal,altTealLight,altGray,altGr -- colors borrowed from terminal.sexy -- altBlack = Color24 (𝕟8 0) (𝕟8 0) $ 𝕟8 0 -- altWhite = Color24 (𝕟8 255) (𝕟8 255) $ 𝕟8 255 --- +-- -- altNight = Color24 (𝕟8 40) (𝕟8 42) $ 𝕟8 46 -- altNightLight = Color24 (𝕟8 55) (𝕟8 59) $ 𝕟8 65 -- altRed = Color24 (𝕟8 165) (𝕟8 66) $ 𝕟8 66 @@ -72,7 +72,7 @@ altBlue,altBlueLight,altPurple,altPurpleLight,altTeal,altTealLight,altGray,altGr -- altGreenLight = Color24 (𝕟8 181) (𝕟8 189) $ 𝕟8 104 -- altOrange = Color24 (𝕟8 222) (𝕟8 147) $ 𝕟8 95 -- altOrangeLight = Color24 (𝕟8 240) (𝕟8 198) $ 𝕟8 116 --- +-- -- altBlue = Color24 (𝕟8 95) (𝕟8 129) $ 𝕟8 157 -- altBlueLight = Color24 (𝕟8 129) (𝕟8 162) $ 𝕟8 190 -- altPurple = Color24 (𝕟8 133) (𝕟8 103) $ 𝕟8 143 @@ -142,5 +142,3 @@ allColors = frhs , ("altTeal" ,altTeal ) , ("altTealLight" ,altTealLight ) ] - - diff --git a/src/UVMHS/Lib/Pretty/Common.hs b/src/UVMHS/Lib/Pretty/Common.hs index 437d4844..8c8d7533 100644 --- a/src/UVMHS/Lib/Pretty/Common.hs +++ b/src/UVMHS/Lib/Pretty/Common.hs @@ -11,7 +11,7 @@ import UVMHS.Lib.Pretty.Shape ----------------- -- Input Chunk -- ----------------- - + data ChunkI = -- length -- ⌄⌄⌄ @@ -25,19 +25,19 @@ data ChunkI = rawChunksI ∷ 𝕊 → ChunkI rawChunksI s = RawChunkI (𝕟64 $ length𝕊 s) s - + splitChunksI ∷ 𝕊 → 𝐼 ChunkI -splitChunksI s = - materialize - $ filter (\ c → c ≢ RawChunkI (𝕟64 0) "") - $ inbetween (NewlineChunkI zero) +splitChunksI s = + materialize + $ filter (\ c → c ≢ RawChunkI (𝕟64 0) "") + $ inbetween (NewlineChunkI zero) $ map rawChunksI $ splitOn𝕊 "\n" s shapeIChunk ∷ ChunkI → Shape shapeIChunk = \case RawChunkI l _ → SingleLine l NewlineChunkI n → newlineShape ⧺ SingleLine n - + extendNewlinesIChunk ∷ ℕ64 → ChunkI → ChunkI extendNewlinesIChunk n = \case RawChunkI l s → RawChunkI l s @@ -73,8 +73,8 @@ shapeOChunk = \case type TreeI = 𝑇V Annotation (𝐼 ChunkI) --- stuff --- between +-- stuff +-- between -- newlines -- ⌄⌄⌄⌄⌄⌄⌄⌄⌄⌄⌄ type TreeO = 𝑇V Formats (Sep () (𝐼A ChunkO)) @@ -105,7 +105,7 @@ alignSummary (SummaryI b sh c) = SummaryI b (alignShapeA sh) c instance Null SummaryI where null = SummaryI False null null instance Append SummaryI where - SummaryI b₁ sh₁ cs₁ ⧺ SummaryI b₂ sh₂ cs₂ = + SummaryI b₁ sh₁ cs₁ ⧺ SummaryI b₂ sh₂ cs₂ = let cs₂' = if not $ shapeIAligned sh₂ then cs₂ @@ -160,7 +160,7 @@ hvalign ha va m n (SummaryO sh cs) = hdm = hd ⌿ 𝕟64 2 -- mmmmmmmm -- wwwwwddd - -- m + -- m -- -- nnnnnnnn -- hhhhhddd @@ -195,7 +195,7 @@ hvalign ha va m n (SummaryO sh cs) = j = fj s in concat [ if i ≡ zero then null else single $ PaddingChunkO i - , xs + , xs , if j ≡ zero then null else single $ PaddingChunkO j ] vwrap i j xs = diff --git a/src/UVMHS/Lib/Pretty/Deriving.hs b/src/UVMHS/Lib/Pretty/Deriving.hs index 1b9a8375..1ce7acb1 100644 --- a/src/UVMHS/Lib/Pretty/Deriving.hs +++ b/src/UVMHS/Lib/Pretty/Deriving.hs @@ -8,8 +8,8 @@ import qualified Language.Haskell.TH as TH import qualified Data.Text as Text --- makePrettySumLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] [(con₁,[conty₁₁,…,conty₁⸤n₁⸥]),…,(conₘ,[contyₘ₁,…,contyₘ⸤nₘ⸥])] ≔ --- [| instance +-- makePrettySumLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] [(con₁,[conty₁₁,…,conty₁⸤n₁⸥]),…,(conₘ,[contyₘ₁,…,contyₘ⸤nₘ⸥])] ≔ +-- [| instance -- (C₁,…,Cₙ -- ,Pretty conty₁₁,…,Pretty conty₁⸤n₁⸥,…,Pretty contyₘ₁,…,Pretty contyₘ⸤nₘ⸥ -- ) ⇒ Pretty (ty a₁ … aₙ) where @@ -25,7 +25,7 @@ makePrettySumLogic cx ty tyargs concontys = do let tyargVars ∷ 𝐿 TH.Type tyargVars = map (TH.VarT ∘ thTyVarBndrName) tyargs instanceCx ∷ 𝐿 TH.Pred - instanceCx = list $ uniques𝑃 $ concat + instanceCx = list $ uniques𝑃 $ concat [ frhs cx , map (\ x → TH.ConT ''Pretty ⊙ x) $ concat $ map snd $ concontys ] @@ -45,8 +45,8 @@ makePrettySum name = do scs ← mapM (ifNoneM (io abortIO) ∘ thViewSimpleCon) cs map tohs $ makePrettySumLogic cx ty tyargs scs --- makePrettyUnionLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] [(con₁,[conty₁₁,…,conty₁⸤n₁⸥]),…,(conₘ,[contyₘ₁,…,contyₘ⸤nₘ⸥])] ≔ --- [| instance +-- makePrettyUnionLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] [(con₁,[conty₁₁,…,conty₁⸤n₁⸥]),…,(conₘ,[contyₘ₁,…,contyₘ⸤nₘ⸥])] ≔ +-- [| instance -- (C₁,…,Cₙ -- ,Pretty conty₁₁,…,Pretty conty₁⸤n₁⸥,…,Pretty contyₘ₁,…,Pretty contyₘ⸤nₘ⸥ -- ) ⇒ Pretty (ty a₁ … aₙ) where @@ -65,18 +65,18 @@ makePrettyUnionLogic cx ty tyargs concontys = do instanceTy ∷ TH.Type instanceTy = TH.ConT ''Pretty ⊙ (TH.ConT ty ⊙⋆ tyargVars) instanceDec ∷ TH.Dec - instanceDec = TH.FunD 'pretty $ tohs $ mapOn conxs $ \ (con :* tmpˣˢ) → + instanceDec = TH.FunD 'pretty $ tohs $ mapOn conxs $ \ (con :* tmpˣˢ) → thSingleClause (single $ TH.ConP con [] $ tohs $ map TH.VarP tmpˣˢ) $ case tmpˣˢ of Nil → TH.VarE 'pretty ⊙ TH.ConE '() x :& Nil → TH.VarE 'pretty ⊙ TH.VarE x - _ → + _ → let prettyXs = mapOn tmpˣˢ $ \ x → TH.VarE 'pretty ⊙ TH.VarE x - in - TH.VarE 'ppCollection - ⊙ (TH.VarE 'ppPun ⊙ thString "⟨") - ⊙ (TH.VarE 'ppPun ⊙ thString "⟩") - ⊙ (TH.VarE 'ppPun ⊙ thString ",") - ⊙$ TH.VarE 'list + in + TH.VarE 'ppCollection + ⊙ (TH.VarE 'ppPun ⊙ thString "⟨") + ⊙ (TH.VarE 'ppPun ⊙ thString "⟩") + ⊙ (TH.VarE 'ppPun ⊙ thString ",") + ⊙$ TH.VarE 'list ⊙$ TH.ListE (tohs prettyXs) return $ single $ TH.InstanceD (tohs None) (tohs instanceCx) instanceTy $ single $ instanceDec @@ -87,7 +87,7 @@ makePrettyUnion name = do map tohs $ makePrettyUnionLogic cx ty tyargs scs -- makePrettyRecordLogic [C₁,…,Cₙ] ty [a₁,…,aₙ] con [(field₁,fieldty₁),…,(fieldₙ,fieldtyₙ)] ≔ --- [| instance +-- [| instance -- (C₁,…,Cₙ -- ,Pretty fieldty₁,…,Pretty fieldtyₙ -- ) ⇒ Pretty (ty a₁ … aₙ) where @@ -111,28 +111,28 @@ makePrettyRecordLogic cx ty tyargs con fieldfieldtys = do return (field :* loweredAfterPrefix :* tmpˣ) let tyargVars = map (TH.VarT ∘ thTyVarBndrName) tyargs instanceCx ∷ 𝐿 TH.Pred - instanceCx = list $ uniques𝑃 $ concat + instanceCx = list $ uniques𝑃 $ concat [ frhs cx , map (\ x → TH.ConT ''Pretty ⊙ x) $ map snd fieldfieldtys ] instanceTy ∷ TH.Type instanceTy = TH.ConT ''Pretty ⊙ (TH.ConT ty ⊙⋆ tyargVars) instanceDec ∷ TH.Dec - instanceDec = - TH.FunD 'pretty - $ single - $ thSingleClause (single $ TH.RecP con $ tohs $ mapOn fieldNameTmps $ \ (field :* _name :* tmpˣ) → (field :* TH.VarP tmpˣ)) - $ TH.VarE 'ppApp - ⊙ (TH.VarE 'ppCon ⊙ (thString $ string $ TH.nameBase con)) - ⊙$ TH.VarE 'list - ⊙$ TH.ListE - $ single - $ TH.VarE 'ppRecord - ⊙ (TH.VarE 'ppPun ⊙ thString "⇒") - ⊙$ TH.VarE 'list - ⊙$ TH.ListE - $ tohs - $ mapOn fieldNameTmps $ \ (frhs → _field :* name :* tmpˣ) → + instanceDec = + TH.FunD 'pretty + $ single + $ thSingleClause (single $ TH.RecP con $ tohs $ mapOn fieldNameTmps $ \ (field :* _name :* tmpˣ) → (field :* TH.VarP tmpˣ)) + $ TH.VarE 'ppApp + ⊙ (TH.VarE 'ppCon ⊙ (thString $ string $ TH.nameBase con)) + ⊙$ TH.VarE 'list + ⊙$ TH.ListE + $ single + $ TH.VarE 'ppRecord + ⊙ (TH.VarE 'ppPun ⊙ thString "⇒") + ⊙$ TH.VarE 'list + ⊙$ TH.ListE + $ tohs + $ mapOn fieldNameTmps $ \ (frhs → _field :* name :* tmpˣ) → TH.ConE '(:*) ⊙ (TH.VarE 'ppString ⊙ (thString name)) ⊙ (TH.VarE 'pretty ⊙ TH.VarE tmpˣ) @@ -144,4 +144,3 @@ makePrettyRecord name = do (con :* fields) ← ifNoneM (io abortIO) $ view thRecCL c let fieldfieldtys = mapOn fields $ \ (frhs → field :* _ :* fieldty) → (field :* fieldty) map tohs $ makePrettyRecordLogic cx ty tyargs con fieldfieldtys - diff --git a/src/UVMHS/Lib/Pretty/Doc.hs b/src/UVMHS/Lib/Pretty/Doc.hs index 46815db1..3c92f6d5 100644 --- a/src/UVMHS/Lib/Pretty/Doc.hs +++ b/src/UVMHS/Lib/Pretty/Doc.hs @@ -156,13 +156,13 @@ ppUT ∷ ℂ → Color → Doc → Doc ppUT c o = ppUndertag c (formats [FG o]) ppPunFmt ∷ Doc → Doc -ppPunFmt = ppFormatParam punctuationFormatL +ppPunFmt = ppFormatParam punctuationFormatL ppPun ∷ 𝕊 → Doc ppPun = ppPunFmt ∘ ppString ppKeyFmt ∷ Doc → Doc -ppKeyFmt = ppFormatParam keywordFormatL +ppKeyFmt = ppFormatParam keywordFormatL ppKey ∷ 𝕊 → Doc ppKey = ppKeyFmt ∘ ppString @@ -320,15 +320,15 @@ ppPostLevel ∷ ℕ64 → Doc → Doc → Doc ppPostLevel i oM xM = ppLevel i $ concat $ iter [xM,oM] ppInf ∷ ℕ64 → Doc → Doc → Doc → Doc -ppInf i o e₁ e₂ = +ppInf i o e₁ e₂ = ppInfLevel i (concat [ppNewlineIfBreak,ppAlign o,ppSpaceIfBreak]) (ppGA e₁) $ ppGA e₂ ppInfl ∷ ℕ64 → Doc → Doc → Doc → Doc -ppInfl i o e₁ e₂ = +ppInfl i o e₁ e₂ = ppInflLevel i (concat [ppNewlineIfBreak,ppAlign o,ppSpaceIfBreak]) (ppGA e₁) $ ppGA e₂ ppInfr ∷ ℕ64 → Doc → Doc → Doc → Doc -ppInfr i o e₁ e₂ = +ppInfr i o e₁ e₂ = ppInfrLevel i (concat [ppNewlineIfBreak,ppAlign o,ppSpaceIfBreak]) (ppGA e₁) $ ppGA e₂ ppPre ∷ ℕ64 → Doc → Doc → Doc @@ -353,15 +353,15 @@ ppPostSep ∷ ℕ64 → Doc → Doc → Doc ppPostSep i o = ppPost i $ ppSpaceIfNoBreak ⧺ o ppInf' ∷ ℕ64 → Doc → Doc → Doc → Doc -ppInf' i o e₁ e₂ = +ppInf' i o e₁ e₂ = ppInfLevel i (concat [ppNewlineIfBreak,ppAlign o,ppNewlineIfBreak]) (ppGA e₁) $ ppGA e₂ ppInfl' ∷ ℕ64 → Doc → Doc → Doc → Doc -ppInfl' i o e₁ e₂ = +ppInfl' i o e₁ e₂ = ppInflLevel i (concat [ppNewlineIfBreak,ppAlign o,ppNewlineIfBreak]) (ppGA e₁) $ ppGA e₂ ppInfr' ∷ ℕ64 → Doc → Doc → Doc → Doc -ppInfr' i o e₁ e₂ = +ppInfr' i o e₁ e₂ = ppInfrLevel i (concat [ppNewlineIfBreak,ppAlign o,ppNewlineIfBreak]) (ppGA e₁) $ ppGA e₂ ppInfSep' ∷ ℕ64 → Doc → Doc → Doc → Doc @@ -375,11 +375,11 @@ ppInfrSep' i o = ppInfr' i $ ppSpaceIfNoBreak ⧺ o ⧺ ppSpaceIfNoBreak ppApp ∷ (ToIter Doc t) ⇒ Doc → t → Doc -ppApp x xs +ppApp x xs | count xs ≡ 𝕟64 0 = ppAlign x | otherwise = Doc $ do l ← askL $ appLevelL ⊚ docEnvPrettyParamsL - unDoc $ ppLevel l $ concat + unDoc $ ppLevel l $ concat [ ppGA x , ppSpaceNewlineIfBreak , concat $ inbetween ppSpaceNewlineIfBreak $ map (ppGA ∘ ppBump) $ iter xs @@ -437,7 +437,7 @@ ppMatrix has vas dss = dss' = svecF 𝕟64s $ \ i → svecF 𝕟64s $ \ j → let SummaryO sh t = sss' ⋕ i ⋕ j in Doc $ tell $ StaticDocA $ SummaryI True (ShapeA False sh) $ treeIO t - in + in ppVertical $ mapOn dss' $ \ ds → ppHorizontal $ inbetween null ds @@ -449,7 +449,7 @@ ppMatrixCells has vas dss = dss' = svecF 𝕟64s $ \ i → svecF 𝕟64s $ \ j → let SummaryO sh t = sss' ⋕ i ⋕ j in Doc $ tell $ StaticDocA $ SummaryI True (ShapeA False sh) $ treeIO t - in + in ppVertical $ inbetween sep $ mapOn dss' $ \ ds → ppHorizontal $ inbetween (ppFG white $ ppString "│") ds @@ -457,7 +457,7 @@ ppMatrixCells has vas dss = -- CLASS -- ----------- -class Pretty a where +class Pretty a where pretty ∷ a → Doc class PrettyM m a | a → m where @@ -481,15 +481,15 @@ instance Pretty ℚ where pretty = ppLit ∘ show𝕊 instance Pretty ℚᴾ where pretty = ppLit ∘ show𝕊 instance Pretty 𝔻 where pretty = ppLit ∘ show𝕊 instance Pretty 𝔻ᴾ where pretty (𝔻ᴾ d) = ppLit $ show𝕊 d -instance Pretty ℝ where - pretty = \case - Integer i → pretty i - Rational q → pretty q +instance Pretty ℝ where + pretty = \case + Integer i → pretty i + Rational q → pretty q Double d → pretty d -instance Pretty ℝᴾ where - pretty = \case - Natural n → pretty n - Rationalᴾ q → pretty q +instance Pretty ℝᴾ where + pretty = \case + Natural n → pretty n + Rationalᴾ q → pretty q Doubleᴾ d → pretty d instance Pretty Time where pretty = ppLit ∘ show𝕊 @@ -506,14 +506,14 @@ escape = \case '\f' → iter $ 𝕤 "\\f" c' → single c' -instance Pretty ℂ where +instance Pretty ℂ where pretty c = ppLit $ string $ concat [ iter $ 𝕤 "'" , escape c , iter $ 𝕤 "'" ] -instance Pretty 𝕊 where +instance Pretty 𝕊 where pretty s = ppLit $ string $ concat [ iter $ 𝕤 "\"" , escape *$ iter s @@ -527,29 +527,29 @@ instance (Pretty a,Pretty b) ⇒ Pretty (a ∧ b) where instance (Pretty a) ⇒ Pretty (() → a) where pretty = pretty ∘ appto () -instance (Pretty a) ⇒ Pretty (𝐿 a) where +instance (Pretty a) ⇒ Pretty (𝐿 a) where pretty = ppCollection (ppPun "[") (ppPun "]") (ppPun ",") ∘ map pretty ∘ iter -instance (Pretty a) ⇒ Pretty [a] where +instance (Pretty a) ⇒ Pretty [a] where pretty = ppCollection (ppPun "[") (ppPun "]") (ppPun ",") ∘ map pretty ∘ iter -instance (Pretty a) ⇒ Pretty (𝐼 a) where +instance (Pretty a) ⇒ Pretty (𝐼 a) where pretty xs = ppApp (ppString "𝐼") $ list [pretty $ list xs] -instance (Pretty a) ⇒ Pretty (𝐼C a) where +instance (Pretty a) ⇒ Pretty (𝐼C a) where pretty xs = ppApp (ppString "𝐼C") $ list [pretty $ list xs] -instance (Pretty a) ⇒ Pretty (𝑄 a) where +instance (Pretty a) ⇒ Pretty (𝑄 a) where pretty xs = ppApp (ppString "𝑄") $ list [pretty $ list xs] -instance (Pretty a) ⇒ Pretty (𝑃 a) where +instance (Pretty a) ⇒ Pretty (𝑃 a) where pretty = ppCollection (ppPun "{") (ppPun "}") (ppPun ",") ∘ map pretty ∘ iter -instance (Pretty k,Pretty v) ⇒ Pretty (k ⇰ v) where +instance (Pretty k,Pretty v) ⇒ Pretty (k ⇰ v) where pretty = ppRecord (ppPun "↦") ∘ map (mapPair pretty pretty) ∘ iter -instance (Pretty a) ⇒ Pretty (𝕍 a) where +instance (Pretty a) ⇒ Pretty (𝕍 a) where pretty xs = ppApp (ppString "𝕍") $ list [pretty $ list xs] -instance (Pretty a) ⇒ Pretty (𝕍S n a) where +instance (Pretty a) ⇒ Pretty (𝕍S n a) where pretty xs = ppApp (ppString "𝕍S") $ list [pretty $ list xs] -instance (Storable a,Pretty a) ⇒ Pretty (𝕌 a) where +instance (Storable a,Pretty a) ⇒ Pretty (𝕌 a) where pretty xs = ppApp (ppString "𝕌") $ list [pretty $ list xs] -instance (Storable a,Pretty a) ⇒ Pretty (𝕌S n a) where +instance (Storable a,Pretty a) ⇒ Pretty (𝕌S n a) where pretty xs = ppApp (ppString "𝕌S") $ list [pretty $ list xs] --- instance (Element a,Pretty a) ⇒ Pretty (𝕄S m n a) where +-- instance (Element a,Pretty a) ⇒ Pretty (𝕄S m n a) where -- pretty xs = ppApp (ppString "𝕄S") $ list [pretty $ list xs] instance (Pretty a) ⇒ Pretty (AddNull a) where @@ -577,9 +577,9 @@ instance (Pretty a) ⇒ Pretty (AddBT a) where instance Pretty Stack.CallStack where pretty = ppString ∘ string ∘ Stack.prettyCallStack colorsDemo ∷ Doc -colorsDemo = - d𝕍 (vec $ iter allColors) HS.$ \ allColorsS → - ppMatrix (const𝕍S 𝕟64s LH) (const𝕍S 𝕟64s TV) $ mapOn allColorsS $ \ (n :* c) → +colorsDemo = + d𝕍 (vec $ iter allColors) HS.$ \ allColorsS → + ppMatrix (const𝕍S 𝕟64s LH) (const𝕍S 𝕟64s TV) $ mapOn allColorsS $ \ (n :* c) → svec $ 𝔢 (ppString n) ⧺♮ 𝔢 (ppFG c $ ppString "XXXXX") ⧺♮ 𝔢 (ppBG c $ ppString "XXXXX") diff --git a/src/UVMHS/Lib/Pretty/DocA.hs b/src/UVMHS/Lib/Pretty/DocA.hs index 88662d10..3fe4832e 100644 --- a/src/UVMHS/Lib/Pretty/DocA.hs +++ b/src/UVMHS/Lib/Pretty/DocA.hs @@ -41,7 +41,7 @@ docAState₀ = DocAState } type DocAM = RWS DocAEnv TreeI DocAState -data DocA = +data DocA = StaticDocA SummaryI | DynamicDocA SummaryI (DocAM ()) makePrisms ''DocA @@ -57,7 +57,7 @@ dynamicDocA = \case DynamicDocA _ d → d instance Null DocA where null = StaticDocA null -instance Append DocA where +instance Append DocA where StaticDocA s₁ ⧺ StaticDocA s₂ = StaticDocA $ s₁ ⧺ s₂ StaticDocA s₁ ⧺ DynamicDocA s₂ r₂ = DynamicDocA (s₁ ⧺ s₂) $ renderSummaryI s₁ ≫ r₂ DynamicDocA s₁ r₁ ⧺ StaticDocA s₂ = DynamicDocA (s₁ ⧺ s₂) $ r₁ ≫ renderSummaryI s₂ @@ -65,7 +65,7 @@ instance Append DocA where instance Monoid DocA renderSummaryI ∷ SummaryI → DocAM () -renderSummaryI s = +renderSummaryI s = let f = if shapeIAligned $ summaryIShape s then alignDocAM @@ -98,7 +98,7 @@ annotateDocA a = \case groupDocAM ∷ SummaryI → DocAM () → DocAM () groupDocAM s xM = do - if summaryIForceBreak s + if summaryIForceBreak s then xM else do lwO ← askL docAEnvMaxLineWidthL @@ -108,7 +108,7 @@ groupDocAM s xM = do col ← getL docAStateColL let ml :* mr = case shapeIShape $ summaryIShape s of SingleLine l → (nest + col + l) :* (rib + l) - MultiLine (ShapeM fl mml ll _) → + MultiLine (ShapeM fl mml ll _) → joins [ nest + col + fl , nest + mml , nest + ll ] :* joins [ rib + fl , mml , ll ] @@ -118,7 +118,7 @@ groupDocAM s xM = do mrb = case rwO of None → True Some rw → mr ≤ rw - case mlb ⩓ mrb of + case mlb ⩓ mrb of True → renderSummaryI s False → xM diff --git a/src/UVMHS/Lib/Pretty/RenderANSI.hs b/src/UVMHS/Lib/Pretty/RenderANSI.hs index 2d7fac7f..8a5739e6 100644 --- a/src/UVMHS/Lib/Pretty/RenderANSI.hs +++ b/src/UVMHS/Lib/Pretty/RenderANSI.hs @@ -82,7 +82,7 @@ sgrBg = \case White → "107" Color8 c → "48;5;" ⧺ show𝕊 c Color24 r g b → "48;2;" ⧺ show𝕊 r ⧺ ";" ⧺ show𝕊 g ⧺ ";" ⧺ show𝕊 b - + sgrUl ∷ 𝔹 → 𝕊 sgrUl True = "4" sgrUl False = "24" @@ -97,7 +97,7 @@ sgrIt False = "23" sgrFormat ∷ Formats → 𝐼A 𝕊 sgrFormat (Formats fg bg ul bd it) = single $ stringS $ iter - [ sgrLeader + [ sgrLeader , concat $ inbetween ";" $ mconcat $ map (mzero𝑂 @𝑄) $ iter [ sgrFg ^$ fg , sgrBg ^$ bg @@ -125,7 +125,7 @@ renderChunkANSI ∷ ChunkO → 𝐼A 𝕊 renderChunkANSI = \case RawChunkO n s → 𝐼A n $ single s PaddingChunkO n → 𝐼A n $ single $ string $ replicate (nat n) ' ' - + formatRenderANSI ∷ Formats → RenderANSIM () → RenderANSIM () formatRenderANSI fm xM = do b ← askL ansiEnvDoFormatL @@ -150,7 +150,7 @@ execRenderANSI = execRenderANSIWith id gv_PPRINT_COLOR ∷ IORef 𝔹 gv_PPRINT_COLOR = io_UNSAFE $ IORef.newIORef True -ppRenderWith ∷ (RenderANSIM () → RenderANSIM ()) +ppRenderWith ∷ (RenderANSIM () → RenderANSIM ()) → (DocAM () → DocAM ()) → (DocM () → DocM ()) → Doc → 𝕊 @@ -175,29 +175,29 @@ ppRenderYesFmt ∷ Doc → 𝕊 ppRenderYesFmt = ppRenderWith (localL ansiEnvDoFormatL True) id id ppRenderWide ∷ Doc → 𝕊 -ppRenderWide = - ppRenderWith id - (localL docAEnvMaxLineWidthL None - ∘ localL docAEnvMaxRibbonWidthL None) +ppRenderWide = + ppRenderWith id + (localL docAEnvMaxLineWidthL None + ∘ localL docAEnvMaxRibbonWidthL None) id ppRenderNarrow ∷ Doc → 𝕊 -ppRenderNarrow = - ppRenderWith id - (localL docAEnvMaxLineWidthL (Some zero) - ∘ localL docAEnvMaxRibbonWidthL (Some zero)) +ppRenderNarrow = + ppRenderWith id + (localL docAEnvMaxLineWidthL (Some zero) + ∘ localL docAEnvMaxRibbonWidthL (Some zero)) id ppRenderNoFmtWide ∷ Doc → 𝕊 -ppRenderNoFmtWide = - ppRenderWith (localL ansiEnvDoFormatL False) +ppRenderNoFmtWide = + ppRenderWith (localL ansiEnvDoFormatL False) (localL docAEnvMaxLineWidthL None ∘ localL docAEnvMaxRibbonWidthL None) id ppRenderNoFmtNarrow ∷ Doc → 𝕊 -ppRenderNoFmtNarrow = - ppRenderWith (localL ansiEnvDoFormatL False) - (localL docAEnvMaxLineWidthL (Some zero) +ppRenderNoFmtNarrow = + ppRenderWith (localL ansiEnvDoFormatL False) + (localL docAEnvMaxLineWidthL (Some zero) ∘ localL docAEnvMaxRibbonWidthL (Some zero)) id diff --git a/src/UVMHS/Lib/Pretty/RenderUndertags.hs b/src/UVMHS/Lib/Pretty/RenderUndertags.hs index a1286641..61d322c3 100644 --- a/src/UVMHS/Lib/Pretty/RenderUndertags.hs +++ b/src/UVMHS/Lib/Pretty/RenderUndertags.hs @@ -8,12 +8,12 @@ import UVMHS.Lib.Sep import UVMHS.Lib.Pretty.Annotation import UVMHS.Lib.Pretty.Common -data RenderUTEnv = RenderUTEnv +data RenderUTEnv = RenderUTEnv { renderUTEnvUnderFormat ∷ 𝑂 (ℂ ∧ Formats) } makeLenses ''RenderUTEnv renderUTEnv₀ ∷ RenderUTEnv -renderUTEnv₀ = RenderUTEnv +renderUTEnv₀ = RenderUTEnv { renderUTEnvUnderFormat = None } data RenderUTState = RenderUTState @@ -95,7 +95,7 @@ annotateRenderUT (Annotation fm ut) = mapOut (annotateSummaryO fm) ∘ mapEnvL r compileRenderUT ∷ TreeI → RenderUT compileRenderUT rd = onRenderUT (\ xM → xM ≫ renderUndertags) $ un𝑇V rd fₑ fₐ - where + where fₑ = RenderUT ∘ eachWith renderChunkUndertags fₐ = onRenderUT ∘ annotateRenderUT diff --git a/src/UVMHS/Lib/Pretty/Shape.hs b/src/UVMHS/Lib/Pretty/Shape.hs index 91a975ea..b5cc8bac 100644 --- a/src/UVMHS/Lib/Pretty/Shape.hs +++ b/src/UVMHS/Lib/Pretty/Shape.hs @@ -25,7 +25,7 @@ import UVMHS.Core -- YYYYYY -- YYYYYY -- ZZZZ --- +-- -- where: -- + XXX: represented by the length of the first line -- + YYYYYY: represented by the maximum length of any line that isn't @@ -47,8 +47,8 @@ data ShapeM = ShapeM } deriving (Eq,Ord,Show) makeLenses ''ShapeM -data Shape = - SingleLine {-# UNPACK #-} ℕ64 +data Shape = + SingleLine {-# UNPACK #-} ℕ64 | MultiLine {-# UNPACK #-} ShapeM deriving (Eq,Ord,Show) makePrisms ''Shape @@ -70,7 +70,7 @@ newlineShape ∷ Shape newlineShape = MultiLine newlineShapeM boxShape ∷ ℕ64 → ℕ64 → Shape -boxShape n nls +boxShape n nls | nls ≡ zero = SingleLine n | otherwise = MultiLine $ ShapeM n n n nls @@ -86,7 +86,7 @@ shapeNewlines = \case instance Null Shape where null = SingleLine zero instance Append Shape where - SingleLine l₁ ⧺ SingleLine l₂ = + SingleLine l₁ ⧺ SingleLine l₂ = -- AAA ⧺ XXX = AAAXXX SingleLine $ l₁ ⧺ l₂ SingleLine l₁ ⧺ MultiLine (ShapeM fl₂ mml₂ ll₂ nls₂) = @@ -94,7 +94,7 @@ instance Append Shape where -- YY YY -- ZZZZ ZZZZ MultiLine $ ShapeM (l₁ + fl₂) mml₂ ll₂ nls₂ - MultiLine (ShapeM fl₁ mml₁ ll₁ nls₁) ⧺ SingleLine l₂ = + MultiLine (ShapeM fl₁ mml₁ ll₁ nls₁) ⧺ SingleLine l₂ = -- □□□□XXX ⧺ AAA = □□□□XXX -- YY YY -- ZZZZ ZZZZAAA @@ -111,11 +111,11 @@ instance Monoid Shape instance Bot Shape where bot = SingleLine zero instance Join Shape where SingleLine l₁ ⊔ SingleLine l₂ = SingleLine $ l₁ ⊔ l₂ - SingleLine l₁ ⊔ MultiLine (ShapeM fl₂ mml₂ ll₂ nls₂) = + SingleLine l₁ ⊔ MultiLine (ShapeM fl₂ mml₂ ll₂ nls₂) = MultiLine $ ShapeM (l₁ ⊔ fl₂) mml₂ ll₂ nls₂ - MultiLine (ShapeM fl₁ mml₁ ll₁ nls₁) ⊔ SingleLine l₂ = + MultiLine (ShapeM fl₁ mml₁ ll₁ nls₁) ⊔ SingleLine l₂ = MultiLine $ ShapeM (l₂ ⊔ fl₁) mml₁ ll₁ nls₁ - MultiLine (ShapeM fl₁ mml₁ ll₁ nls₁) ⊔ MultiLine (ShapeM fl₂ mml₂ ll₂ nls₂) + MultiLine (ShapeM fl₁ mml₁ ll₁ nls₁) ⊔ MultiLine (ShapeM fl₂ mml₂ ll₂ nls₂) | nls₁ > nls₂ = MultiLine $ ShapeM (fl₁ ⊔ fl₂) (mml₁ ⊔ mml₂ ⊔ ll₂) ll₁ nls₁ | nls₁ < nls₂ = MultiLine $ ShapeM (fl₁ ⊔ fl₂) (mml₁ ⊔ mml₂ ⊔ ll₁) ll₂ nls₂ | otherwise = MultiLine $ ShapeM (fl₁ ⊔ fl₂) (mml₁ ⊔ mml₂) (ll₁ ⊔ ll₂) $ nls₁ ⊔ nls₂ @@ -143,7 +143,7 @@ instance Join Shape where -- aligned + non-aligned = aligned -- aligned + aligned = aligned -- --- When the shape is a single line, it is always non-aligned +-- When the shape is a single line, it is always non-aligned -- (so, aligned = False) data ShapeA = ShapeA @@ -159,11 +159,11 @@ instance Append ShapeA where let sh₂' = if not a₂ -- ‣ sh₁ is single-line - -- ‣ sh₂ is single-line + -- ‣ sh₂ is single-line -- -- □□□□XXX ⧺ □□□□AAA = □□□□XXXAAA -- - -- ‣ sh₁ is single-line + -- ‣ sh₁ is single-line -- ‣ sh₂ is multiline non-aligned -- -- □□□□XXX ⧺ □□□□AAA = □□□□XXXAAA @@ -172,12 +172,12 @@ instance Append ShapeA where -- -- ‣ sh₁ is multiline non-aligned -- ‣ sh₂ is single-line - -- + -- -- □□□□XXX ⧺ □□□□AAA = □□□□XXX - -- YY YY + -- YY YY -- ZZZZ ZZZZAAA - -- - -- ‣ sh₁ is multiline non-aligned + -- + -- ‣ sh₁ is multiline non-aligned -- ‣ sh₂ is multiline non-aligned -- □□□□XXX ⧺ □□□□AAA = □□□□XXX -- YY BB YY @@ -188,12 +188,12 @@ instance Append ShapeA where -- ‣ sh₁ is multiline aligned -- ‣ sh₂ is single-line -- - -- □□□□XXX ⧺ □□□□AAA = □□□□XXX - -- ⋅⋅⋅⋅YY ⋅⋅⋅⋅YY + -- □□□□XXX ⧺ □□□□AAA = □□□□XXX + -- ⋅⋅⋅⋅YY ⋅⋅⋅⋅YY -- ⋅⋅⋅⋅ZZZZ ⋅⋅⋅⋅ZZZZAAA -- -- ‣ sh₁ is multiline aligned - -- ‣ sh₂ is multiline non-aligned + -- ‣ sh₂ is multiline non-aligned -- -- □□□□XXX ⧺ □□□□AAA = □□□□XXX -- ⋅⋅⋅⋅YY BB ⋅⋅⋅⋅YY @@ -205,8 +205,8 @@ instance Append ShapeA where -- ‣ sh₁ is single-lined -- ‣ sh₂ is multiline aligned -- - -- □□□□XXX ⧺ □□□□AAA = □□□□XXXAAA - -- ⋅⋅⋅⋅BB ⋅⋅⋅⋅␣␣␣BB + -- □□□□XXX ⧺ □□□□AAA = □□□□XXXAAA + -- ⋅⋅⋅⋅BB ⋅⋅⋅⋅␣␣␣BB -- ⋅⋅⋅⋅CCCC ⋅⋅⋅⋅␣␣␣CCCC -- -- ‣ sh₁ is multiline non-aligned @@ -219,7 +219,7 @@ instance Append ShapeA where -- ␣␣␣␣CCCC -- -- ‣ sh₁ is multiline aligned - -- ‣ sh₂ is multiline aligned + -- ‣ sh₂ is multiline aligned -- -- □□□□XXX ⧺ □□□□AAA = □□□□XXX -- ⋅⋅⋅⋅YY ⋅⋅⋅⋅BB ⋅⋅⋅⋅YY @@ -227,7 +227,7 @@ instance Append ShapeA where -- ⋅⋅⋅⋅␣␣␣␣BB -- ⋅⋅⋅⋅␣␣␣␣CCCC -- - else + else case sh₂ of MultiLine (ShapeM fl₂ mml₂ ll₂ nls₂) → MultiLine $ ShapeM fl₂ (shapeLastLength sh₁ + mml₂) (shapeLastLength sh₁ + ll₂) nls₂ diff --git a/src/UVMHS/Lib/Rand.hs b/src/UVMHS/Lib/Rand.hs index 92899949..d1fa5445 100644 --- a/src/UVMHS/Lib/Rand.hs +++ b/src/UVMHS/Lib/Rand.hs @@ -14,22 +14,22 @@ class MonadRand m where newtype RG = RG { unRG ∷ R.StdGen } instance MonadRand IO where - rng f = R.getStdRandom $ \ ℊ → + rng f = R.getStdRandom $ \ ℊ → let RG ℊ' :* x = runState (RG ℊ) f in (x,ℊ') wrapPrimRandu ∷ (R.StdGen → (a,R.StdGen)) → State RG a wrapPrimRandu f = do RG ℊ ← get - let (x,ℊ') = f ℊ + let (x,ℊ') = f ℊ put $ RG ℊ' return x wrapPrimRandr ∷ ((a,a) → R.StdGen → (a,R.StdGen)) → a → a → State RG a wrapPrimRandr f xl xh = do - RG ℊ ← get - let (x,ℊ') = f (xl,xh) ℊ - put $ RG ℊ' + RG ℊ ← get + let (x,ℊ') = f (xl,xh) ℊ + put $ RG ℊ' return x ------------------------ @@ -126,21 +126,21 @@ rand ∷ ∀ a m. (MonadRand m,Fuzzy a) ⇒ ℕ64 → ℕ64 → m a rand r d = rng $ runFuzzyMRG (FuzzyEnv r d) fuzzy wrchoose ∷ ∀ t m a. (Monad m,MonadRand m,ToIter (ℕ64 ∧ (() → m a)) t) ⇒ t → m a -wrchoose wxs +wrchoose wxs | isEmpty wxs = error "wrchoose not defined for zero elements" | otherwise = do let w₀ = sum $ map fst $ iter wxs let _ = if w₀ ≡ 0 then error "wrchoose not defined for zero total weight" else () n ← randr 1 w₀ runContT (\ n' → error $ "impossible" ⧺ show𝕊 n') $ mfoldOnFrom wxs 0 $ \ (w :* xM) wᵢ → - let wᵢ' = wᵢ+w + let wᵢ' = wᵢ+w in if n ≤ wᵢ' then callCC $ \ _𝓀 → lift $ xM () else return wᵢ' rchoose ∷ (Monad m,MonadRand m,ToIter (() → m a) t) ⇒ t → m a -rchoose xMs +rchoose xMs | isEmpty xMs = error "rchoose not defined for zero elements" | otherwise = wrchoose $ map (one :*) $ iter xMs @@ -151,7 +151,7 @@ randSml ∷ ∀ a m. (MonadRand m,Fuzzy a) ⇒ m a randSml = rand 4 4 randMed ∷ ∀ a m. (MonadRand m,Fuzzy a) ⇒ m a -randMed = rand 16 16 +randMed = rand 16 16 randLrg ∷ ∀ a m. (MonadRand m,Fuzzy a) ⇒ m a randLrg = rand 64 64 @@ -161,7 +161,7 @@ untilPass f xM = loop where loop = do x ← xM - if f x + if f x then return x else loop @@ -183,36 +183,36 @@ instance Fuzzy 𝔻 where fuzzy = randrRadius ∘ dbl *$ askL fuzzyEnvRadiu instance Fuzzy () where fuzzy = return () -instance Fuzzy 𝔹 where +instance Fuzzy 𝔹 where fuzzy = rchoose $ map (const ∘ return) [ True , False ] -instance (Fuzzy a) ⇒ Fuzzy (𝑂 a) where +instance (Fuzzy a) ⇒ Fuzzy (𝑂 a) where fuzzy = rchoose $ map const [ return None , Some ^$ fuzzy ] -instance (Fuzzy a,Fuzzy b) ⇒ Fuzzy (a ∨ b) where +instance (Fuzzy a,Fuzzy b) ⇒ Fuzzy (a ∨ b) where fuzzy = rchoose $ map const [ Inl ^$ fuzzy , Inr ^$ fuzzy ] -instance (Fuzzy a,Fuzzy b) ⇒ Fuzzy (a ∧ b) where +instance (Fuzzy a,Fuzzy b) ⇒ Fuzzy (a ∧ b) where fuzzy = do x ← fuzzy y ← fuzzy return $ x :* y -instance (Fuzzy a) ⇒ Fuzzy (𝐿 a) where +instance (Fuzzy a) ⇒ Fuzzy (𝐿 a) where fuzzy = do w ← (×2) ^$ askL fuzzyEnvRadiusL list ^$ mapMOn (upto w) $ const fuzzy -instance (Ord k,Fuzzy k,Fuzzy v) ⇒ Fuzzy (k ⇰ v) where +instance (Ord k,Fuzzy k,Fuzzy v) ⇒ Fuzzy (k ⇰ v) where fuzzy = assoc ^$ fuzzy @(𝐿 _) instance (Fuzzy a) ⇒ Fuzzy (() → a) where fuzzy = const ^$ fuzzy diff --git a/src/UVMHS/Lib/Sep.hs b/src/UVMHS/Lib/Sep.hs index c0d93e9d..ed8a01dc 100644 --- a/src/UVMHS/Lib/Sep.hs +++ b/src/UVMHS/Lib/Sep.hs @@ -2,7 +2,7 @@ module UVMHS.Lib.Sep where import UVMHS.Core -data Sep i a = +data Sep i a = SepE a | SepN a i (𝐼C (a ∧ i)) a @@ -14,7 +14,7 @@ instance (Append a) ⇒ Append (Sep i a) where SepE x₁ ⧺ SepE x₂ = SepE $ x₁ ⧺ x₂ SepE x₁ ⧺ SepN x₂₁ i₂ xis₂ x₂₂ = SepN (x₁ ⧺ x₂₁) i₂ xis₂ x₂₂ SepN x₁₁ i₁ xis₁ x₁₂ ⧺ SepE x₂ = SepN x₁₁ i₁ xis₁ $ x₁₂ ⧺ x₂ - SepN x₁₁ i₁ xis₁ x₁₂ ⧺ SepN x₂₁ i₂ xis₂ x₂₂ = + SepN x₁₁ i₁ xis₁ x₁₂ ⧺ SepN x₂₁ i₂ xis₂ x₂₂ = let xis' = xis₁ ⧺ single ((x₁₂ ⧺ x₂₁) :* i₂) ⧺ xis₂ in SepN x₁₁ i₁ xis' x₂₂ instance (Monoid a) ⇒ Monoid (Sep i a) @@ -25,7 +25,7 @@ instance ToIter a (Sep a a) where SepN x₁ i xis x₂ → concat [ single x₁ , single i - , do x' :* i' ← iter xis + , do x' :* i' ← iter xis iter [x',i'] , single x₂ ] @@ -41,7 +41,6 @@ mapSep ∷ (i → j) → (a → b) → Sep i a → Sep j b mapSep f g = \case SepE x → SepE $ g x SepN x₁ i xis x₂ → SepN (g x₁) (f i) (map (mapPair g f) xis) $ g x₂ - + mapSepI ∷ (i → j) → Sep i a → Sep j a mapSepI f = mapSep f id - diff --git a/src/UVMHS/Lib/Substitution.hs b/src/UVMHS/Lib/Substitution.hs index 5625dee0..478f88d7 100644 --- a/src/UVMHS/Lib/Substitution.hs +++ b/src/UVMHS/Lib/Substitution.hs @@ -38,7 +38,7 @@ subSubstElem substE (SubstElem 𝑠 ueO) = SubstElem zero $ \ () → substE 𝑠 -------------------------------- -- ℯ ⩴ i | s⇈e -data SSubstElem s e = +data SSubstElem s e = Var_SSE ℕ64 | Trm_SSE (SubstElem s e) deriving (Eq,Ord,Show) @@ -48,7 +48,7 @@ instance (Pretty s,Pretty e) ⇒ Pretty (SSubstElem s e) where Var_SSE i → pretty $ DVar i Trm_SSE e → pretty e -instance (Ord s,Fuzzy s,Fuzzy e) ⇒ Fuzzy (SSubstElem s e) where +instance (Ord s,Fuzzy s,Fuzzy e) ⇒ Fuzzy (SSubstElem s e) where fuzzy = rchoose $ map const [ Var_SSE ^$ fuzzy , Trm_SSE ^$ fuzzy @@ -68,7 +68,7 @@ subSSubstElem substV substE = \case -- DE BRUIJN SUBSTITUTION -- ---------------------------- --- 𝓈 ⩴ ⟨ρ,es,ι⟩ +-- 𝓈 ⩴ ⟨ρ,es,ι⟩ -- INVARIANT: |es| + ι ≥ 0 data DSubst s e = DSubst { dsubstShift ∷ ℕ64 @@ -78,7 +78,7 @@ data DSubst s e = DSubst makeLenses ''DSubst makePrettyRecord ''DSubst -instance (Ord s,Fuzzy s,Fuzzy e) ⇒ Fuzzy (DSubst s e) where +instance (Ord s,Fuzzy s,Fuzzy e) ⇒ Fuzzy (DSubst s e) where fuzzy = do ρ ← fuzzy 𝔰 ← fuzzy @@ -118,7 +118,7 @@ dsubstVar ∷ DSubst 𝑠 e → ℕ64 → SSubstElem 𝑠 e dsubstVar (DSubst ρ̇ es ι) ṅ = let 𝔰̇ = csize es n = intΩ64 ṅ - in + in if | ṅ < ρ̇ → Var_SSE ṅ | ṅ < 𝔰̇+ρ̇ → es ⋕! (ṅ-ρ̇) @@ -128,16 +128,16 @@ dsubstVar (DSubst ρ̇ es ι) ṅ = -- GENERIC SCOPED SUBSTITUTION -- ------------------------------- -data GSubst s₁ s₂ e = GSubst +data GSubst s₁ s₂ e = GSubst { gsubstGVars ∷ s₁ ⇰ SubstElem s₂ e , gsubstMetas ∷ s₁ ⇰ SubstElem s₂ e - , gsubstSubst ∷ s₂ ⇰ DSubst s₂ e - } + , gsubstSubst ∷ s₂ ⇰ DSubst s₂ e + } deriving (Eq,Ord,Show) makeLenses ''GSubst makePrettyUnion ''GSubst -instance (Ord s₁,Ord s₂,Fuzzy s₁,Fuzzy s₂,Fuzzy e) ⇒ Fuzzy (GSubst s₁ s₂ e) where +instance (Ord s₁,Ord s₂,Fuzzy s₁,Fuzzy s₂,Fuzzy e) ⇒ Fuzzy (GSubst s₁ s₂ e) where fuzzy = do esᴳ ← fuzzy esᴹ ← fuzzy @@ -145,7 +145,7 @@ instance (Ord s₁,Ord s₂,Fuzzy s₁,Fuzzy s₂,Fuzzy e) ⇒ Fuzzy (GSubst s return $ GSubst esᴳ esᴹ 𝓈 𝓈shiftG ∷ (Ord s₂) ⇒ s₂ ⇰ ℕ64 → GSubst s₁ s₂ e → GSubst s₁ s₂ e -𝓈shiftG 𝑠 (GSubst esᴳ esᴹ 𝓈s) = +𝓈shiftG 𝑠 (GSubst esᴳ esᴹ 𝓈s) = let esᴳ' = map (introSubstElem 𝑠) esᴳ 𝓈s' = kmapOn 𝓈s $ \ s (DSubst ρ es ι) → let ρ' = ρ + ifNone 0 (𝑠 ⋕? s) @@ -170,9 +170,9 @@ instance (Ord s₁,Ord s₂,Fuzzy s₁,Fuzzy s₂,Fuzzy e) ⇒ Fuzzy (GSubst s -- 𝓈₁ ≜ ⟨ρ₁,es₁,ι₁⟩ -- 𝓈₂ ≜ ⟨ρ₂,es₂,ι₂⟩ --- 𝔰₁ = |es₁| --- 𝔰₂ = |es₂| --- (𝓈₂⧺𝓈₁)(i) +-- 𝔰₁ = |es₁| +-- 𝔰₂ = |es₂| +-- (𝓈₂⧺𝓈₁)(i) -- == -- 𝓈₂(𝓈₁(i)) -- == @@ -209,11 +209,11 @@ instance (Ord s₁,Ord s₂,Fuzzy s₁,Fuzzy s₂,Fuzzy e) ⇒ Fuzzy (GSubst s -- 𝔰 ≜ |es| -- ρ+𝔰 = (ρ₁+𝔰₁)⊔(ρ₂+𝔰₂-ι₁) -- 𝔰 = ((ρ₁+𝔰₁)⊔(ρ₂+𝔰₂-ι₁))-ρ -appendGSubst ∷ - (Ord s₁,Ord s₂) - ⇒ (GSubst s₁ s₂ e → e → 𝑂 e) - → GSubst s₁ s₂ e - → GSubst s₁ s₂ e +appendGSubst ∷ + (Ord s₁,Ord s₂) + ⇒ (GSubst s₁ s₂ e → e → 𝑂 e) + → GSubst s₁ s₂ e + → GSubst s₁ s₂ e → GSubst s₁ s₂ e appendGSubst esubst 𝓈̂₂ 𝓈̂₁ = let GSubst esᴳ₁ esᴹ₁ 𝓈s₁ = 𝓈̂₁ @@ -223,8 +223,8 @@ appendGSubst esubst 𝓈̂₂ 𝓈̂₁ = esᴳ₁' = map (subSubstElem $ esub 𝓈̂₂) esᴳ₁ esᴹ₁' = map (subSubstElem $ esub 𝓈̂₂) esᴹ₁ 𝓈s₁' = kmapOn 𝓈s₁ $ \ s (DSubst ρ̇₁ es₁ ι₁) → DSubst ρ̇₁ (mapOn es₁ $ ℯsub s 𝓈̂₂) ι₁ - esᴳ = esᴳ₁' ⩌ esᴳ₂ - esᴹ = esᴹ₁' ⩌ esᴹ₂ + esᴳ = esᴳ₁' ⩌ esᴳ₂ + esᴹ = esᴹ₁' ⩌ esᴹ₂ 𝓈s = dunionByOn 𝓈s₂ 𝓈s₁' $ \ 𝓈₂@(DSubst ρ̇₂ es₂ ι₂) 𝓈₁@(DSubst ρ̇₁ es₁ ι₁) → if | isNullDSubst 𝓈₁ → 𝓈₂ @@ -239,8 +239,8 @@ appendGSubst esubst 𝓈̂₂ 𝓈̂₁ = ι = ι₁+ι₂ 𝔰 = ((ρ₁+𝔰₁)⊔(ρ₂+𝔰₂-ι₁))-ρ δ = ρ - es = vecF (natΩ64 𝔰) $ \ ṅ → - let n = intΩ64 ṅ + δ in + es = vecF (natΩ64 𝔰) $ \ ṅ → + let n = intΩ64 ṅ + δ in if | n < ρ₁⊓(ρ₂+𝔰₂) → es₂ ⋕! natΩ64 (n-ρ₂) | n < ρ₁ → Var_SSE $ natΩ64 $ n+ι₂ @@ -272,13 +272,13 @@ data SubstAction s e = SubstAction } makeLenses ''SubstAction -data SubstEnv s e = +data SubstEnv s e = FVsSubstEnv (FreeVarsAction s) | SubSubstEnv (SubstAction s e) makePrisms ''SubstEnv -newtype SubstM s e a = SubstM - { unSubstM ∷ UContT (ReaderT (SubstEnv s e) (FailT (WriterT (s ⇰ 𝑃 𝕐) ID))) a +newtype SubstM s e a = SubstM + { unSubstM ∷ UContT (ReaderT (SubstEnv s e) (FailT (WriterT (s ⇰ 𝑃 𝕐) ID))) a } deriving ( Return,Bind,Functor,Monad , MonadUCont @@ -289,13 +289,13 @@ newtype SubstM s e a = SubstM mkSubstM ∷ (∀ u. SubstEnv s e → (a → SubstEnv s e → (s ⇰ 𝑃 𝕐) ∧ 𝑂 u) → (s ⇰ 𝑃 𝕐) ∧ 𝑂 u) → SubstM s e a -mkSubstM f = SubstM $ UContT (\ 𝓀 → ReaderT $ \ γ → FailT $ WriterT $ ID $ f γ $ \ x γ' → +mkSubstM f = SubstM $ UContT (\ 𝓀 → ReaderT $ \ γ → FailT $ WriterT $ ID $ f γ $ \ x γ' → unID $ unWriterT $ unFailT $ runReaderT γ' $ 𝓀 x) -runSubstM ∷ - SubstEnv s e - → (a → SubstEnv s e → (s ⇰ 𝑃 𝕐) ∧ 𝑂 u) - → SubstM s e a +runSubstM ∷ + SubstEnv s e + → (a → SubstEnv s e → (s ⇰ 𝑃 𝕐) ∧ 𝑂 u) + → SubstM s e a → (s ⇰ 𝑃 𝕐) ∧ 𝑂 u runSubstM γ 𝓀 = unID ∘ unWriterT ∘ unFailT ∘ runReaderT γ ∘ runUContT 𝓀' ∘ unSubstM where @@ -320,8 +320,8 @@ fvsWith ∷ (Substy s e a) ⇒ (FreeVarsAction s → FreeVarsAction s) → a → fvsWith f = fst ∘ runSubstMHalt (FVsSubstEnv $ f $ FreeVarsAction (const $ const True) null) ∘ substy fvsSMetas ∷ (Ord s,Substy s e a) ⇒ 𝑃 s → a → s ⇰ 𝑃 𝕏 -fvsSMetas ss = - map (pow ∘ filterMap (view mVarL) ∘ iter) +fvsSMetas ss = + map (pow ∘ filterMap (view mVarL) ∘ iter) ∘ fvsWith (update freeVarsActionFilterL $ \ s y → s ∈ ss ⩓ shape mVarL y) fvsMetas ∷ (Ord s,Substy s e a) ⇒ s → a → 𝑃 𝕏 @@ -447,7 +447,7 @@ substyBdr s 𝓋 x = do case bO of None → skip Some b → do - if b + if b then umodifyEnv $ alter subSubstEnvL $ alter substActionSubstL $ flip (⧺) $ concat [ 𝓈snintro $ s ↦ x ↦ 1 @@ -468,7 +468,7 @@ substyVar xO s 𝓋 n = do when (n ≥ n₀) $ \ () → do let n' = n-n₀ y = elim𝑂 (const DVar) (flip NVar) xO n' - when (freeVarsActionFilter 𝒶 s y) $ \ () → + when (freeVarsActionFilter 𝒶 s y) $ \ () → tell $ s ↦ single y return $ 𝓋 n SubSubstEnv 𝒶 → do @@ -491,7 +491,7 @@ substyGVar s 𝓋 x = do case γ of FVsSubstEnv 𝒶 → do let y = GVar x - when (freeVarsActionFilter 𝒶 s y) $ \ () → + when (freeVarsActionFilter 𝒶 s y) $ \ () → tell $ s ↦ single y return $ 𝓋 x SubSubstEnv 𝓈A → do @@ -506,7 +506,7 @@ substyMVar s 𝓋 x = do case γ of FVsSubstEnv 𝒶 → do let y = MVar x - when (freeVarsActionFilter 𝒶 s y) $ \ () → + when (freeVarsActionFilter 𝒶 s y) $ \ () → tell $ s ↦ single y return $ 𝓋 x SubSubstEnv 𝓈A → do diff --git a/src/UVMHS/Lib/Testing.hs b/src/UVMHS/Lib/Testing.hs index 13a5b9f5..c18020cd 100644 --- a/src/UVMHS/Lib/Testing.hs +++ b/src/UVMHS/Lib/Testing.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -module UVMHS.Lib.Testing +module UVMHS.Lib.Testing ( module UVMHS.Lib.Testing ) where @@ -64,17 +64,17 @@ runTests verb tests = do valD :* p ← io $ valdpIO let b = p () tags ← list ∘ reverse ^$ ask - if b + if b then do when verb $ \ () → io $ pprint $ ppHorizontal [ ppFG teal $ ppBD $ ppString $ concat $ inbetween ":" tags - , ppFG green $ ppString "PASS" + , ppFG green $ ppString "PASS" , ppFG grayDark lD ] tell $ TestsOut null $ tags ↦ (one :* zero) else do - when verb $ \ () → + when verb $ \ () → io $ pprint $ ppHorizontal [ ppFG teal $ ppBD $ ppString $ concat $ inbetween ":" tags , ppFG red $ ppString "FAIL" @@ -89,25 +89,25 @@ runTests verb tests = do let src = concat $ inbetween ":" tags in ppVertical $ concat [ if p ≡ 0 then null𝐼 else single $ - ppHorizontal + ppHorizontal [ ppFG green $ ppString "PASSED" , ppBD $ ppFG green $ ppString $ alignRight (𝕟 3) $ show𝕊 p , ppPun $ concat ["» ",src] ] - , if f ≡ 0 then null else single $ - ppHorizontal + , if f ≡ 0 then null else single $ + ppHorizontal [ ppFG red $ ppString "FAILED" , ppBD $ ppFG red $ ppString $ alignRight (𝕟 3) $ show𝕊 f , ppPun $ concat ["» ",src] ] ] - + ] when (not $ isEmpty $ iter $ testsOutFailures o) $ \ () → pprint $ ppVertical [ ppHeader "FAILED TESTS" - , pretty $ concat $ mapOn (iter $ testsOutFailures o) $ \ (tags :* lsds) → - concat $ mapOn lsds $ \ (lD :* srcD :* valD) → + , pretty $ concat $ mapOn (iter $ testsOutFailures o) $ \ (tags :* lsds) → + concat $ mapOn lsds $ \ (lD :* srcD :* valD) → key𝑇A (concat $ inbetween ":" tags) $ concat [ key𝑇A "loc" $ val𝑇A $ ppFG grayDark lD , key𝑇A "src" $ val𝑇A srcD @@ -167,7 +167,7 @@ buildTests ∷ TH.Q [TH.Dec] buildTests = do testEQs ← ifNone null ∘ frhs𝑂 ^$ TH.getQ @(𝐼 (TH.Code TH.Q (𝑇D Test))) l ← TH.location - let modNameS = frhsChars $ TH.loc_module l + let modNameS = frhsChars $ TH.loc_module l testsNameS = "g__TESTS__" ⧺ replace𝕊 "." "__" modNameS testsName = TH.mkName $ tohsChars testsNameS testEQs' ∷ TH.Code TH.Q [𝑇D Test] @@ -178,11 +178,11 @@ buildTests = do [ single ^$ TH.sigD testsName [t| 𝑇D Test |] , [d| $(TH.varP testsName) = $(TH.unTypeCode testsEQ) |] ] - + testModules ∷ 𝔹 → [𝕊] → TH.Code TH.Q (IO ()) testModules verb nsS = let nss = map (splitOn𝕊 ":") nsS - testsNamesS = mapOn nss $ \ ns → + testsNamesS = mapOn nss $ \ ns → concat $ inbetween "." $ mapLastOn ns $ \ n → "g__TESTS__" ⧺ replace𝕊 "." "__" n testsNames = mapOn testsNamesS $ \ testsNameS → TH.mkName $ tohsChars testsNameS testNamesE = mapOn testsNames $ \ testsName → TH.varE testsName diff --git a/src/UVMHS/Lib/TreeAnnote.hs b/src/UVMHS/Lib/TreeAnnote.hs index 5b766c03..720fbc42 100644 --- a/src/UVMHS/Lib/TreeAnnote.hs +++ b/src/UVMHS/Lib/TreeAnnote.hs @@ -24,7 +24,7 @@ data 𝑇 i a = fold𝑇With ∷ (Monoid b) ⇒ (a → b) → (i → b → b) → 𝑇 i a → b fold𝑇With fₗ fₐ = loop - where + where loop = \case N𝑇 → null B𝑇 xs ys → loop xs ⧺ loop ys @@ -47,11 +47,11 @@ instance Functor (𝑇 i) where map f = fold𝑇With (L𝑇 ∘ f) annote -- VIRTUAL -- ------------- -data 𝑇V i a = 𝑇V - { un𝑇V ∷ ∀ b. (Monoid b) - ⇒ (a → b) - → (i → b → b) - → b +data 𝑇V i a = 𝑇V + { un𝑇V ∷ ∀ b. (Monoid b) + ⇒ (a → b) + → (i → b → b) + → b } fold𝑇VOn ∷ (Monoid b) ⇒ 𝑇V i a → (a → b) → (i → b → b) → b diff --git a/src/UVMHS/Lib/TreeNested.hs b/src/UVMHS/Lib/TreeNested.hs index 85d9feb0..a963637c 100644 --- a/src/UVMHS/Lib/TreeNested.hs +++ b/src/UVMHS/Lib/TreeNested.hs @@ -8,13 +8,13 @@ data 𝑇A a = 𝑇A , nest𝑇A ∷ 𝐼 (𝕊 ∧ 𝑇A a) } deriving (Show) -instance Null (𝑇A a) where +instance Null (𝑇A a) where null = 𝑇A null null -instance Append (𝑇A a) where +instance Append (𝑇A a) where 𝑇A m₁ n₁ ⧺ 𝑇A m₂ n₂ = 𝑇A (m₁ ⧺ m₂) $ n₁ ⧺ n₂ instance Monoid (𝑇A a) -instance Eps (𝑇A a) where +instance Eps (𝑇A a) where eps = 𝑇A null null instance Seq (𝑇A a) where 𝑇A v₁ n₁ ▷ 𝑇A v₂ n₂ @@ -24,7 +24,7 @@ instance Seqoid (𝑇A a) fold𝑇AWith ∷ (Monoid b) ⇒ (𝐼 a → b) → (𝕊 → b → b) → 𝑇A a → b fold𝑇AWith fₗ fₙ = loop - where + where loop (𝑇A vs sxs) = concat [ fₗ vs , concat $ mapOn (iter sxs) $ \ (s :* xs) → @@ -52,18 +52,18 @@ instance (Pretty a) ⇒ Pretty (𝑇A a) where ] ] -data 𝑇D a = 𝑇D +data 𝑇D a = 𝑇D { vals𝑇D ∷ 𝐼 a , nest𝑇D ∷ 𝕊 ⇰ 𝑇D a } deriving (Show) -instance Null (𝑇D a) where +instance Null (𝑇D a) where null = 𝑇D null null -instance Append (𝑇D a) where +instance Append (𝑇D a) where 𝑇D m₁ n₁ ⧺ 𝑇D m₂ n₂ = 𝑇D (m₁ ⧺ m₂) $ n₁ ⧺ n₂ instance Monoid (𝑇D a) -instance Eps (𝑇D a) where +instance Eps (𝑇D a) where eps = 𝑇D null null instance Seq (𝑇D a) where 𝑇D v₁ n₁ ▷ 𝑇D v₂ n₂ @@ -73,7 +73,7 @@ instance Seqoid (𝑇D a) fold𝑇DWith ∷ (Monoid b) ⇒ (𝐼 a → b) → (𝕊 → b → b) → 𝑇D a → b fold𝑇DWith fₗ fₙ = loop - where + where loop (𝑇D vs sxs) = concat [ fₗ vs , concat $ mapOn (iter sxs) $ \ (s :* xs) → diff --git a/src/UVMHS/Lib/Variables.hs b/src/UVMHS/Lib/Variables.hs index 46f484d4..13fdc3f9 100644 --- a/src/UVMHS/Lib/Variables.hs +++ b/src/UVMHS/Lib/Variables.hs @@ -17,7 +17,7 @@ data 𝕏 = 𝕏 makeLenses ''𝕏 -- fancy variables -data 𝕐 = +data 𝕐 = DVar ℕ64 | NVar ℕ64 𝕏 | GVar 𝕏 diff --git a/src/UVMHS/Lib/Window.hs b/src/UVMHS/Lib/Window.hs index 761d5bbf..8fa3bdfb 100644 --- a/src/UVMHS/Lib/Window.hs +++ b/src/UVMHS/Lib/Window.hs @@ -23,7 +23,7 @@ overflowL ∷ WindowL i a → 𝔹 overflowL (ZerWindowL _) = False overflowL (OneWindowL o _ _ _) = o -instance (Null a) ⇒ Null (WindowL i a) where +instance (Null a) ⇒ Null (WindowL i a) where null = ZerWindowL null instance (Append a) ⇒ Append (WindowL i a) where ZerWindowL x ⧺ ZerWindowL y = ZerWindowL $ x ⧺ y @@ -31,7 +31,7 @@ instance (Append a) ⇒ Append (WindowL i a) where OneWindowL True x i y ⧺ _ = OneWindowL True x i y OneWindowL False x i y ⧺ ZerWindowL z = OneWindowL False x i $ y ⧺ z OneWindowL False x i y ⧺ OneWindowL _ z _ _ = OneWindowL True x i $ y ⧺ z -instance (Monoid a) ⇒ Monoid (WindowL i a) +instance (Monoid a) ⇒ Monoid (WindowL i a) instance ToIter a (WindowL a a) where iter (ZerWindowL x) = single x @@ -60,7 +60,7 @@ overflowR ∷ WindowR i a → 𝔹 overflowR (ZerWindowR _) = False overflowR (OneWindowR o _ _ _) = o -instance (Null a) ⇒ Null (WindowR i a) where +instance (Null a) ⇒ Null (WindowR i a) where null = ZerWindowR null instance (Append a) ⇒ Append (WindowR i a) where ZerWindowR x ⧺ ZerWindowR y = ZerWindowR $ x ⧺ y @@ -68,7 +68,7 @@ instance (Append a) ⇒ Append (WindowR i a) where _ ⧺ OneWindowR True x i y = OneWindowR True x i y ZerWindowR x ⧺ OneWindowR False y i z = OneWindowR False (x ⧺ y) i z OneWindowR _ _ _ x ⧺ OneWindowR False y i z = OneWindowR True (x ⧺ y) i z -instance (Monoid a) ⇒ Monoid (WindowR i a) +instance (Monoid a) ⇒ Monoid (WindowR i a) instance ToIter a (WindowR a a) where iter (ZerWindowR x) = single x @@ -98,78 +98,78 @@ renderWindowR dR , concat dR ] | otherwise = concat dR - + -- import UVMHS.Core -- ------------ -- -- Swivel -- -- ------------ --- +-- -- swivelL ∷ 𝐿 a → a → a ∧ 𝐿 a -- swivelL Nil x = x :* Nil -- swivelL (x :& xs) y = -- let x' :* xs' = swivelL xs y -- in x :* (x' :& xs') --- +-- -- swivelR ∷ a → 𝐿 a → 𝐿 a ∧ a -- swivelR x Nil = Nil :* x -- swivelR x (y :& xs) = -- let xs' :* x' = swivelR y xs -- in (x :& xs') :* x' --- +-- -- iswivelL ∷ 𝐿 (a ∧ i) → a → a ∧ 𝐿 (i ∧ a) -- iswivelL Nil x = x :* Nil -- iswivelL ((x :* i) :& xis) y = -- let x' :* ixs = iswivelL xis y -- in x :* ((i :* x') :& ixs) --- +-- -- iswivelR ∷ a → 𝐿 (i ∧ a) → 𝐿 (a ∧ i) ∧ a -- iswivelR x Nil = Nil :* x -- iswivelR x ((i :* y) :& ixs) = -- let xis :* x' = iswivelR y ixs -- in ((x :* i) :& xis) :* x' --- +-- -- ------------ -- -- Window -- -- ------------ --- --- data Window i a = +-- +-- data Window i a = -- WindowE a -- | WindowS ℕ64 a i (𝐼 (a ∧ i)) a --- +-- -- windowI ∷ (Null a) ⇒ i → Window i a -- windowI i = WindowS one null i null null --- +-- -- instance (Null a) ⇒ Null (Window i a) where null = WindowE null -- instance (Append a) ⇒ Append (Window i a) where -- WindowE x₁ ⧺ WindowE x₂ = WindowE $ x₁ ⧺ x₂ -- WindowE x₁ ⧺ WindowS n x₂₁ i₂ xis₂ x₂₂ = WindowS n (x₁ ⧺ x₂₁) i₂ xis₂ x₂₂ -- WindowS n x₁₁ i₁ xis₁ x₁₂ ⧺ WindowE x₂ = WindowS n x₁₁ i₁ xis₁ $ x₁₂ ⧺ x₂ --- WindowS n₁ x₁₁ i₁ xis₁ x₁₂ ⧺ WindowS n₂ x₂₁ i₂ xis₂ x₂₂ = +-- WindowS n₁ x₁₁ i₁ xis₁ x₁₂ ⧺ WindowS n₂ x₂₁ i₂ xis₂ x₂₂ = -- let xis' = xis₁ ⧺ single ((x₁₁ ⧺ x₂₁) :* i₂) ⧺ xis₂ -- in WindowS (n₁ + n₂) x₁₁ i₁ xis' x₂₂ -- instance (Monoid a) ⇒ Monoid (Window i a) --- +-- -- ------------- -- -- FWindow -- -- ------------- --- +-- -- windowWidth ∷ ℕ64 -- windowWidth = 𝕟64 2 --- --- data FWindow i a = +-- +-- data FWindow i a = -- FWindowE a -- | FWindowS ℕ64 a i (𝐿 (a ∧ i)) a --- +-- -- fwindowI ∷ (Null a) ⇒ i → FWindow i a -- fwindowI i = FWindowS one null i null null --- +-- -- instance (Null a) ⇒ Null (FWindow i a) where null = FWindowE null -- instance (Append a) ⇒ Append (FWindow i a) where -- FWindowE x₁ ⧺ FWindowE x₂ = FWindowE $ x₁ ⧺ x₂ -- FWindowE x₁ ⧺ FWindowS n x₂₁ i₂ xis₂ x₂₂ = FWindowS n (x₁ ⧺ x₂₁) i₂ xis₂ x₂₂ -- FWindowS n x₁₁ i₁ xis₁ x₁₂ ⧺ FWindowE x₂ = FWindowS n x₁₁ i₁ xis₁ $ x₁₂ ⧺ x₂ --- FWindowS n₁ x₁₁ i₁ xis₁ x₁₂ ⧺ FWindowS n₂ x₂₁ i₂ xis₂ x₂₂ = +-- FWindowS n₁ x₁₁ i₁ xis₁ x₁₂ ⧺ FWindowS n₂ x₂₁ i₂ xis₂ x₂₂ = -- | n₂ ≡ windowWidth + 1 = FWindowS n₂ (x₁₂ ⧺ x₂₁) i₂ xis₂ x₂₂ -- let n = n₁ + n₂ -- in case n > (windowWidth + one) of @@ -181,60 +181,59 @@ renderWindowR dR -- let xis = xis₁ ⧺ ((x₁₂ ⧺ x₂₁) :* i₂) :& xis₂ -- in FWindowS n x₁₁ i₁ xis x₂₂ -- instance (Monoid a) ⇒ Monoid (FWindow i a) --- --- data LWindow i a = +-- +-- data LWindow i a = -- LWindowE a -- | LWindowS ℕ64 a i (𝐼 (a ∧ i)) a --- +-- -- lwindowI ∷ (Null a) ⇒ i → LWindow i a -- lwindowI i = LWindowS null i null null --- +-- -- instance (Null a) ⇒ Null (LWindow i a) where null = LWindowE null -- instance (Append a) ⇒ Append (LWindow i a) where -- LWindowE x₁ ⧺ LWindowE x₂ = LWindowE $ x₁ ⧺ x₂ -- LWindowE x₁ ⧺ LWindowS x₂₁ i₂ xis₂ x₂₂ = LWindowS (x₁ ⧺ x₂₁) i₂ xis₂ x₂₂ -- LWindowS x₁₁ i₁ xis₁ x₁₂ ⧺ LWindowE x₂ = LWindowS x₁₁ i₁ xis₁ $ x₁₂ ⧺ x₂ --- LWindowS x₁₁ i₁ xis₁ x₁₂ ⧺ LWindowS x₂₁ i₂ xis₂ x₂₂ = +-- LWindowS x₁₁ i₁ xis₁ x₁₂ ⧺ LWindowS x₂₁ i₂ xis₂ x₂₂ = -- let xis' = reverse $ iter $ firstN (nat windowWidth) $ list $ reverse $ xis₁ ⧺ single ((x₁₁ ⧺ x₂₁) :* i₂) ⧺ xis₂ -- in LWindowS x₁₁ i₁ xis' x₂₂ -- instance (Monoid a) ⇒ Monoid (LWindow i a) --- --- -- data WindowR i a = WindowR +-- +-- -- data WindowR i a = WindowR -- -- { windowRHead ∷ 𝐿 (a ∧ i) -- -- , windowRTail ∷ a -- -- } deriving (Eq,Ord,Show) --- -- +-- -- -- -- instance (Null a) ⇒ Null (WindowR i a) where null = WindowR null null -- -- instance (Append a) ⇒ Append (WindowR i a) where -- -- WindowR xss₁ x₁ ⧺ WindowR xss₂ x₂ = case xxs₂ of -- -- Nil → WindowL xss₁ (x₁ ⧺ x₂) -- -- (x₂' :* s₂) :& xss₂' → WindowL (xss₁ ⧺ ((x₁ ⧺ x₂') :* xss₂)) x₂ -- -- instance (Monoid a) ⇒ Monoid (WindowL i a) --- -- instance ToStream a (SepL a a) where +-- -- instance ToStream a (SepL a a) where -- -- stream (WindowL x sxs) = stream $ list $ concat --- -- [ single x --- -- , concat $ mapOn (reverse sxs) $ \ (i' :* x') → +-- -- [ single x +-- -- , concat $ mapOn (reverse sxs) $ \ (i' :* x') → -- -- iter [i',x'] -- -- ] -- -- instance ToIter a (WindowL a a) where iter = iter ∘ stream --- -- --- -- data WindowL i a = WindowL +-- -- +-- -- data WindowL i a = WindowL -- -- { windowLHead ∷ a -- -- , windowLTail ∷ 𝐿 (i ∧ a) -- -- } deriving (Eq,Ord,Show) --- -- +-- -- -- -- instance (Null a) ⇒ Null (WindowL i a) where null = WindowL null null -- -- instance (Append a) ⇒ Append (WindowL i a) where -- -- WindowL x₁ sxs₁ ⧺ WindowL x₂ sxs₂ = case sxs₁ of -- -- Nil → WindowL (x₁ ⧺ x₂) sxs₂ -- -- (s₁ :* x₁') :& sxs₁' → WindowL x₁ $ firstN windowWidth $ sxs₂ ⧺ ((s₁ :* (x₁' ⧺ x₂)) :& sxs₁) -- -- instance (Monoid a) ⇒ Monoid (WindowL i a) --- -- instance ToStream a (WindowL a a) where +-- -- instance ToStream a (WindowL a a) where -- -- stream (WindowL x sxs) = stream $ list $ concat --- -- [ single x --- -- , concat $ mapOn (reverse sxs) $ \ (i' :* x') → +-- -- [ single x +-- -- , concat $ mapOn (reverse sxs) $ \ (i' :* x') → -- -- iter [i',x'] -- -- ] -- -- instance ToIter a (WindowL a a) where iter = iter ∘ stream --- -- - +-- -- diff --git a/src/UVMHS/Lib/ZerInf.hs b/src/UVMHS/Lib/ZerInf.hs index 380198a9..4a3ff992 100644 --- a/src/UVMHS/Lib/ZerInf.hs +++ b/src/UVMHS/Lib/ZerInf.hs @@ -123,7 +123,7 @@ instance (Times a) ⇒ Times (AddInf a) where AddInf x × AddInf y = AddInf $ x × y instance (Divide a,Zero a,Eq a) ⇒ Divide (AddInf a) where Inf / Inf = error "∞ / ∞" - Inf / y + Inf / y | y ≡ zero = error "∞ / 0" | otherwise = Inf _ / Inf = zero @@ -136,7 +136,7 @@ instance (DivMod a,Zero a) ⇒ DivMod (AddInf a) where x ÷ Inf = x AddInf x ÷ AddInf y = AddInf $ x ÷ y instance (Pon a,One a) ⇒ Pon (AddInf a) where - Inf ^^ n + Inf ^^ n | n ≡ zero = one | otherwise = Inf AddInf x ^^ n = AddInf $ x ^^ n diff --git a/src/UVMHS/Tests/Core.hs b/src/UVMHS/Tests/Core.hs index afd539dd..195994c6 100644 --- a/src/UVMHS/Tests/Core.hs +++ b/src/UVMHS/Tests/Core.hs @@ -30,11 +30,11 @@ import UVMHS.Lib.Testing 𝔱 "core:lens" [| alter (keyL $ 𝕤 "x") (map (+ 𝕟 1)) ("x" ↦♭ 𝕟 1) |] [| "x" ↦♭ 𝕟 2 |] 𝔱 "core:lens" [| alter (keyL $ 𝕤 "x") (map (+ 𝕟 1)) ("y" ↦♭ 𝕟 1) |] [| "y" ↦♭ 𝕟 1 |] -𝔱 "core:lens" [| alter (keyL $ 𝕤 "x") (map (+ 𝕟 1)) (dict𝐷 ["x" ↦♭ 𝕟 10,"y" ↦♭ 𝕟 20]) |] +𝔱 "core:lens" [| alter (keyL $ 𝕤 "x") (map (+ 𝕟 1)) (dict𝐷 ["x" ↦♭ 𝕟 10,"y" ↦♭ 𝕟 20]) |] [| dict𝐷 ["x" ↦♭ 𝕟 11,"y" ↦♭ 𝕟 20] |] 𝔱 "core:lens" [| alter (keyL $ 𝕤 "x") (const None) ("x" ↦♭ 𝕟 1) |] [| dø𝐷 |] 𝔱 "core:lens" [| alter (keyL $ 𝕤 "x") (const None) ("y" ↦♭ 𝕟 1) |] [| "y" ↦♭ 𝕟 1 |] -𝔱 "core:lens" [| alter (keyL $ 𝕤 "x") (const None) (dict𝐷 ["x" ↦♭ 𝕟 10,"y" ↦♭ 𝕟 20]) |] +𝔱 "core:lens" [| alter (keyL $ 𝕤 "x") (const None) (dict𝐷 ["x" ↦♭ 𝕟 10,"y" ↦♭ 𝕟 20]) |] [| dict𝐷 ["y" ↦♭ 𝕟 20] |] newtype CR a = CR { unCR ∷ ContT ℕ64 (ReaderT (ℕ64 ∧ ℕ64) ID) a } @@ -48,7 +48,7 @@ runCR ∷ ℕ64 → ℕ64 → CR ℕ64 → ℕ64 runCR x y xM = unID $ runReaderT (x :* y) $ evalContT $ unCR xM execCR ∷ CR ℕ64 → ℕ64 -execCR = runCR 0 0 +execCR = runCR 0 0 𝔱 "core:monads:cr" [| 0 |] [| execCR $ do fst ^$ ask |] 𝔱 "core:monads:cr" [| 0 |] [| execCR $ do snd ^$ ask |] @@ -56,7 +56,7 @@ execCR = runCR 0 0 𝔱 "core:monads:cr" [| 10 |] [| execCR $ do putEnvL fstL 10 ; x :* y ← ask ; return $ x + y |] 𝔱 "core:monads:cr" [| 10 |] [| execCR $ do putEnvL fstL 10 ; reset (do x :* y ← ask ; return $ x + y) |] 𝔱 "core:monads:cr" [| 0 |] [| execCR $ do _←reset $ (do putEnvL fstL 10;return $ 𝕟64 0);x:*y←ask;return $ x + y |] -𝔱 "core:monads:cr" [| 110 |] +𝔱 "core:monads:cr" [| 110 |] [| execCR $ do putEnvL fstL 10;x ← reset $ (do putEnvL fstL 100;askL fstL);y←askL fstL;return $ x + y |] -- Note: this is why MonadReader has askL/localL as primitives, and not ask/local 𝔱 "core:monads:cr" [| 2 |] [| execCR $ do localL fstL 1 $ putEnvL sndL 2 ; askL sndL |] @@ -72,7 +72,7 @@ runUR ∷ ℕ64 → ℕ64 → UR ℕ64 → ℕ64 runUR x y xM = unID $ runReaderT (x :* y) $ evalUContT $ unUR xM execUR ∷ UR ℕ64 → ℕ64 -execUR = runUR 0 0 +execUR = runUR 0 0 𝔱 "core:monads:ur" [| 0 |] [| execUR $ do fst ^$ ask |] 𝔱 "core:monads:ur" [| 0 |] [| execUR $ do snd ^$ ask |] @@ -86,4 +86,3 @@ execUR = runUR 0 0 𝔱 "core:monads:ur" [| 2 |] [| execUR $ do localL fstL 1 $ uputEnvL sndL 2 ; askL sndL |] buildTests - diff --git a/src/UVMHS/Tests/Substitution.hs b/src/UVMHS/Tests/Substitution.hs index 01b56ec4..5833c956 100644 --- a/src/UVMHS/Tests/Substitution.hs +++ b/src/UVMHS/Tests/Substitution.hs @@ -31,21 +31,21 @@ import UVMHS.Lang.ULC 𝔱 "subst:bind" [| subst (𝓈dbind [ulc| λ → 0 |]) [ulc| λ → 1 |] |] [| Some [ulc| λ → λ → 0 |] |] 𝔱 "subst:bind" [| subst (𝓈dbind [ulc| λ → 1 |]) [ulc| λ → 1 |] |] [| Some [ulc| λ → λ → 2 |] |] -𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 0 |]) [ulc| λ → 0 |] |] +𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 0 |]) [ulc| λ → 0 |] |] [| Some [ulc| λ → 0 |] |] -𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 1 |]) [ulc| λ → 0 |] |] +𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 1 |]) [ulc| λ → 0 |] |] [| Some [ulc| λ → 0 |] |] -𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 0 |]) [ulc| λ → 1 |] |] +𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 0 |]) [ulc| λ → 1 |] |] [| Some [ulc| λ → 1 |] |] -𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 1 |]) [ulc| λ → 1 |] |] +𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 1 |]) [ulc| λ → 1 |] |] [| Some [ulc| λ → 1 |] |] -𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 2 |]) [ulc| λ → 0 |] |] +𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 2 |]) [ulc| λ → 0 |] |] [| Some [ulc| λ → 0 |] |] -𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 2 |]) [ulc| λ → 1 |] |] +𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 2 |]) [ulc| λ → 1 |] |] [| Some [ulc| λ → 1 |] |] -𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 1 |]) [ulc| λ → 2 |] |] +𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 1 |]) [ulc| λ → 2 |] |] [| Some [ulc| λ → λ → 3 |] |] -𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 2 |]) [ulc| λ → 2 |] |] +𝔱 "subst:shift" [| subst (𝓈dshift 1 $ 𝓈dbind [ulc| λ → 2 |]) [ulc| λ → 2 |] |] [| Some [ulc| λ → λ → 4 |] |] -- append -- @@ -64,22 +64,22 @@ import UVMHS.Lang.ULC 𝔱 "subst:⧺" [| subst (𝓈dintro 1) [ulc| λ → 1 |] |] [| Some [ulc| λ → 2 |] |] 𝔱 "subst:⧺" [| subst (null ⧺ 𝓈dintro 1 ⧺ null) [ulc| λ → 1 |] |] [| Some [ulc| λ → 2 |] |] -𝔱 "subst:⧺" [| subst (𝓈dbind [ulc| λ → 0 |]) [ulc| λ → 1 |] |] +𝔱 "subst:⧺" [| subst (𝓈dbind [ulc| λ → 0 |]) [ulc| λ → 1 |] |] [| Some [ulc| λ → λ → 0 |] |] -𝔱 "subst:⧺" [| subst (null ⧺ 𝓈dbind [ulc| λ → 0 |] ⧺ null) [ulc| λ → 1 |] |] +𝔱 "subst:⧺" [| subst (null ⧺ 𝓈dbind [ulc| λ → 0 |] ⧺ null) [ulc| λ → 1 |] |] [| Some [ulc| λ → λ → 0 |] |] 𝔱 "subst:⧺" [| subst (𝓈dintro 2) [ulc| λ → 1 |] |] [| Some [ulc| λ → 3 |] |] 𝔱 "subst:⧺" [| subst (𝓈dintro 1 ⧺ 𝓈dintro 1) [ulc| λ → 1 |] |] [| Some [ulc| λ → 3 |] |] -𝔱 "subst:⧺" [| subst (𝓈dbind [ulc| λ → 0 |]) [ulc| λ → 1 |] |] +𝔱 "subst:⧺" [| subst (𝓈dbind [ulc| λ → 0 |]) [ulc| λ → 1 |] |] [| Some [ulc| λ → λ → 0 |] |] -𝔱 "subst:⧺" [| subst (𝓈dshift 1 (𝓈dbind [ulc| λ → 0 |]) ⧺ 𝓈dintro 1) [ulc| λ → 1 |] |] +𝔱 "subst:⧺" [| subst (𝓈dshift 1 (𝓈dbind [ulc| λ → 0 |]) ⧺ 𝓈dintro 1) [ulc| λ → 1 |] |] [| Some [ulc| λ → λ → 0 |] |] -𝔱 "subst:⧺" [| subst (𝓈dintro 1 ⧺ 𝓈dbind [ulc| 1 |]) [ulc| 0 (λ → 2) |] |] +𝔱 "subst:⧺" [| subst (𝓈dintro 1 ⧺ 𝓈dbind [ulc| 1 |]) [ulc| 0 (λ → 2) |] |] [| Some [ulc| 2 (λ → 2) |] |] -𝔱 "subst:⧺" [| subst (𝓈dshift 1 (𝓈dbind [ulc| 1 |]) ⧺ 𝓈dintro 1) [ulc| 0 (λ → 2) |] |] +𝔱 "subst:⧺" [| subst (𝓈dshift 1 (𝓈dbind [ulc| 1 |]) ⧺ 𝓈dintro 1) [ulc| 0 (λ → 2) |] |] [| Some [ulc| 2 (λ → 2) |] |] 𝔱 "subst:⧺" [| subst (𝓈dintro 1) *$ subst (𝓈dshift 1 null) [ulc| 0 |] |] @@ -155,7 +155,7 @@ import UVMHS.Lang.ULC -- fuzzing -- -𝔣 "zzz:subst:hom:refl" 100 +𝔣 "zzz:subst:hom:refl" 100 [| do e ← randSml @ULCExpRaw return e |] @@ -169,21 +169,21 @@ import UVMHS.Lang.ULC |] [| \ (𝓈₁ :* 𝓈₂ :* e) → subst (𝓈₁ ⧺ 𝓈₂) e ≡ (subst 𝓈₁ *$ subst 𝓈₂ e) |] -𝔣 "zzz:subst:lunit:⧺" 100 +𝔣 "zzz:subst:lunit:⧺" 100 [| do 𝓈 ← randSml @(Subst () ULCExpRaw) e ← randSml @ULCExpRaw return $ 𝓈 :* e |] [| \ (𝓈 :* e) → subst (null ⧺ 𝓈) e ≡ subst 𝓈 e |] -𝔣 "zzz:subst:runit:⧺" 100 +𝔣 "zzz:subst:runit:⧺" 100 [| do 𝓈 ← randSml @(Subst () ULCExpRaw) e ← randSml @ULCExpRaw return $ 𝓈 :* e |] [| \ (𝓈 :* e) → subst (𝓈 ⧺ null) e ≡ subst 𝓈 e |] -𝔣 "zzz:subst:trans:⧺" 100 +𝔣 "zzz:subst:trans:⧺" 100 [| do 𝓈₁ ← randSml @(Subst () ULCExpRaw) 𝓈₂ ← randSml @(Subst () ULCExpRaw) 𝓈₃ ← randSml @(Subst () ULCExpRaw) @@ -211,13 +211,13 @@ import UVMHS.Lang.ULC e₂ ← randSml @ULCExpRaw return $ e₁ :* e₂ |] - [| \ (e₁ :* e₂) → + [| \ (e₁ :* e₂) → (subst (𝓈dintro 1) *$ subst (𝓈dbind e₁) e₂) - ≡ + ≡ (subst (𝓈dshift 1 $ 𝓈dbind e₁) *$ subst (𝓈dintro 1) e₂) |] -𝔣 "zzz:subst:dist:shift/⧺:nometa" 100 +𝔣 "zzz:subst:dist:shift/⧺:nometa" 100 [| do n ← randSml @ℕ64 𝓈₁ ← alter (gsubstMetasL ⊚ unSubstL) null ^$ randSml @(Subst () ULCExpRaw) 𝓈₂ ← alter (gsubstMetasL ⊚ unSubstL) null ^$ randSml @(Subst () ULCExpRaw)