diff options
Diffstat (limited to 'src/AST')
| -rw-r--r-- | src/AST/Accum.hs | 2 | ||||
| -rw-r--r-- | src/AST/Pretty.hs | 2 | ||||
| -rw-r--r-- | src/AST/SplitLets.hs | 4 | ||||
| -rw-r--r-- | src/AST/Types.hs | 14 |
4 files changed, 10 insertions, 12 deletions
diff --git a/src/AST/Accum.hs b/src/AST/Accum.hs index e84034b..03369c8 100644 --- a/src/AST/Accum.hs +++ b/src/AST/Accum.hs @@ -79,6 +79,7 @@ lemZeroInfoD2 :: STy t -> ZeroInfo (D2 t) :~: TNil lemZeroInfoD2 STNil = Refl lemZeroInfoD2 (STPair a b) | Refl <- lemZeroInfoD2 a, Refl <- lemZeroInfoD2 b = Refl lemZeroInfoD2 (STEither a b) | Refl <- lemZeroInfoD2 a, Refl <- lemZeroInfoD2 b = Refl +lemZeroInfoD2 (STLEither a b) | Refl <- lemZeroInfoD2 a, Refl <- lemZeroInfoD2 b = Refl lemZeroInfoD2 (STMaybe a) | Refl <- lemZeroInfoD2 a = Refl lemZeroInfoD2 (STArr _ a) | Refl <- lemZeroInfoD2 a = Refl lemZeroInfoD2 (STScal STI32) = Refl @@ -87,7 +88,6 @@ lemZeroInfoD2 (STScal STF32) = Refl lemZeroInfoD2 (STScal STF64) = Refl lemZeroInfoD2 (STScal STBool) = Refl lemZeroInfoD2 (STAccum _) = error "Accumulators disallowed in source program" -lemZeroInfoD2 (STLEither a b) | Refl <- lemZeroInfoD2 a, Refl <- lemZeroInfoD2 b = Refl -- -- | Additional info needed for accumulation. This is empty unless there is -- -- sparsity in the monoid. diff --git a/src/AST/Pretty.hs b/src/AST/Pretty.hs index e09f3ae..2bb78d4 100644 --- a/src/AST/Pretty.hs +++ b/src/AST/Pretty.hs @@ -388,6 +388,7 @@ ppSTy' :: Int -> STy t -> Doc q ppSTy' _ STNil = ppString "1" ppSTy' d (STPair a b) = ppParen (d > 7) $ ppSTy' 8 a <> ppString " * " <> ppSTy' 8 b ppSTy' d (STEither a b) = ppParen (d > 6) $ ppSTy' 7 a <> ppString " + " <> ppSTy' 7 b +ppSTy' d (STLEither a b) = ppParen (d > 6) $ ppSTy' 7 a <> ppString " ⊕ " <> ppSTy' 7 b ppSTy' d (STMaybe t) = ppParen (d > 10) $ ppString "Maybe " <> ppSTy' 11 t ppSTy' d (STArr n t) = ppParen (d > 10) $ ppString "Arr " <> ppString (show (fromSNat n)) <> ppString " " <> ppSTy' 11 t @@ -398,7 +399,6 @@ ppSTy' _ (STScal sty) = ppString $ case sty of STF64 -> "f64" STBool -> "bool" ppSTy' d (STAccum t) = ppParen (d > 10) $ ppString "Accum " <> ppSMTy' 11 t -ppSTy' d (STLEither a b) = ppParen (d > 6) $ ppSTy' 7 a <> ppString " ⊕ " <> ppSTy' 7 b ppSMTy :: Int -> SMTy t -> String ppSMTy d ty = render $ ppSMTy' d ty diff --git a/src/AST/SplitLets.hs b/src/AST/SplitLets.hs index 159934d..1379e35 100644 --- a/src/AST/SplitLets.hs +++ b/src/AST/SplitLets.hs @@ -123,11 +123,11 @@ split typ = case typ of STPair{} -> splitRec (EVar ext typ IZ) typ STNil -> other STEither{} -> other + STLEither{} -> other STMaybe{} -> other STArr{} -> other STScal{} -> other STAccum{} -> other - STLEither{} -> other where other :: (Pointers (t : env) t, Bindings Ex (t : env) '[]) other = (Point typ IZ, BTop) @@ -142,11 +142,11 @@ splitRec rhs typ = case typ of (p2, bs2) = splitRec (ESnd ext (sinkWithBindings bs1 `weakenExpr` rhs)) b in (PPair (PWeak (sinkWithBindings bs2) p1) p2, bconcat bs1 bs2) STEither{} -> other + STLEither{} -> other STMaybe{} -> other STArr{} -> other STScal{} -> other STAccum{} -> other - STLEither{} -> other where other :: (Pointers (t : env) t, Bindings Ex env '[t]) other = (Point typ IZ, BPush BTop (typ, rhs)) diff --git a/src/AST/Types.hs b/src/AST/Types.hs index efb1e04..a3b7302 100644 --- a/src/AST/Types.hs +++ b/src/AST/Types.hs @@ -23,12 +23,11 @@ type data Ty = TNil | TPair Ty Ty | TEither Ty Ty + | TLEither Ty Ty | TMaybe Ty | TArr Nat Ty -- ^ rank, element type | TScal ScalTy | TAccum Ty -- ^ contained type must be a monoid type - -- sparse monoid types - | TLEither Ty Ty type data ScalTy = TI32 | TI64 | TF32 | TF64 | TBool @@ -37,12 +36,11 @@ data STy t where STNil :: STy TNil STPair :: STy a -> STy b -> STy (TPair a b) STEither :: STy a -> STy b -> STy (TEither a b) + STLEither :: STy a -> STy b -> STy (TLEither a b) STMaybe :: STy a -> STy (TMaybe a) STArr :: SNat n -> STy t -> STy (TArr n t) STScal :: SScalTy t -> STy (TScal t) STAccum :: SMTy t -> STy (TAccum t) - -- sparse monoid types - STLEither :: STy a -> STy b -> STy (TLEither a b) deriving instance Show (STy t) instance GCompare STy where @@ -53,6 +51,8 @@ instance GCompare STy where STPair{} _ -> GLT ; _ STPair{} -> GGT (STEither a b) (STEither a' b') -> gorderingLift2 (gcompare a a') (gcompare b b') STEither{} _ -> GLT ; _ STEither{} -> GGT + (STLEither a b) (STLEither a' b') -> gorderingLift2 (gcompare a a') (gcompare b b') + STLEither{} _ -> GLT ; _ STLEither{} -> GGT (STMaybe a) (STMaybe a') -> gorderingLift1 (gcompare a a') STMaybe{} _ -> GLT ; _ STMaybe{} -> GGT (STArr n t) (STArr n' t') -> gorderingLift2 (gcompare n n') (gcompare t t') @@ -60,9 +60,7 @@ instance GCompare STy where (STScal t) (STScal t') -> gorderingLift1 (gcompare t t') STScal{} _ -> GLT ; _ STScal{} -> GGT (STAccum t) (STAccum t') -> gorderingLift1 (gcompare t t') - STAccum{} _ -> GLT ; _ STAccum{} -> GGT - (STLEither a b) (STLEither a' b') -> gorderingLift2 (gcompare a a') (gcompare b b') - -- STLEither{} _ -> GLT ; _ STLEither{} -> GGT + -- STAccum{} _ -> GLT ; _ STAccum{} -> GGT instance TestEquality STy where testEquality = geq instance GEq STy where geq = defaultGeq @@ -177,11 +175,11 @@ hasArrays :: STy t' -> Bool hasArrays STNil = False hasArrays (STPair a b) = hasArrays a || hasArrays b hasArrays (STEither a b) = hasArrays a || hasArrays b +hasArrays (STLEither a b) = hasArrays a || hasArrays b hasArrays (STMaybe t) = hasArrays t hasArrays STArr{} = True hasArrays STScal{} = False hasArrays STAccum{} = True -hasArrays (STLEither a b) = hasArrays a || hasArrays b type family Tup env where Tup '[] = TNil |