diff options
| author | Tom Smeding <tom@tomsmeding.com> | 2025-03-26 23:46:17 +0100 |
|---|---|---|
| committer | Tom Smeding <tom@tomsmeding.com> | 2025-03-26 23:46:17 +0100 |
| commit | f1e867838db63da71fea660740c23ab276a43a6c (patch) | |
| tree | f20f9b813801faf27c944f26fa5973434acc96a4 /src | |
| parent | e26f5ab33e1aee655df9469e03f88afd76a6335c (diff) | |
Language: support Maybe and Accum terms
Diffstat (limited to 'src')
| -rw-r--r-- | src/Language.hs | 16 | ||||
| -rw-r--r-- | src/Language/AST.hs | 13 |
2 files changed, 29 insertions, 0 deletions
diff --git a/src/Language.hs b/src/Language.hs index d2eee7f..a66b8b6 100644 --- a/src/Language.hs +++ b/src/Language.hs @@ -69,6 +69,15 @@ inr = NEInr knownTy case_ :: NExpr env (TEither a b) -> (Var name1 a :-> NExpr ('(name1, a) : env) c) -> (Var name2 b :-> NExpr ('(name2, b) : env) c) -> NExpr env c case_ e (v1 :-> e1) (v2 :-> e2) = NECase e v1 e1 v2 e2 +nothing :: KnownTy a => NExpr env (TMaybe a) +nothing = NENothing knownTy + +just :: NExpr env a -> NExpr env (TMaybe a) +just = NEJust + +maybe_ :: NExpr env b -> (Var name a :-> NExpr ('(name, a) : env) b) -> NExpr env (TMaybe a) -> NExpr env b +maybe_ a (v :-> b) c = NEMaybe a v b c + constArr_ :: forall t n env. (KnownNat n, KnownScalTy t) => Array n (ScalRep t) -> NExpr env (TArr n (TScal t)) constArr_ x = let ty = knownScalTy @@ -157,6 +166,13 @@ custom :: (Var n1 a :-> Var n2 b :-> NExpr ['(n2, b), '(n1, a)] t) custom (n1 :-> n2 :-> a) (nf1 :-> nf2 :-> b) (nr1 :-> nr2 :-> c) e1 e2 = NECustom n1 n2 a nf1 nf2 b nr1 nr2 c e1 e2 +with :: forall t a env acname. KnownTy t => NExpr env (D2 t) -> (Var acname (TAccum t) :-> NExpr ('(acname, TAccum t) : env) a) -> NExpr env (TPair a (D2 t)) +with a (n :-> b) = NEWith (knownTy @t) a n b + +accum :: KnownTy t => SAcPrj p t a -> NExpr env (AcIdx p t) -> NExpr env (D2 a) -> NExpr env (TAccum t) -> NExpr env TNil +accum p a b c = NEAccum knownTy p a b c + + (.==) :: (KnownScalTy st, ScalIsNumeric st ~ True) => NExpr env (TScal st) -> NExpr env (TScal st) -> NExpr env (TScal TBool) a .== b = oper (OEq knownScalTy) (pair a b) infix 4 .== diff --git a/src/Language/AST.hs b/src/Language/AST.hs index b36e151..84544f8 100644 --- a/src/Language/AST.hs +++ b/src/Language/AST.hs @@ -42,6 +42,9 @@ data NExpr env t where NEInl :: STy b -> NExpr env a -> NExpr env (TEither a b) NEInr :: STy a -> NExpr env b -> NExpr env (TEither a b) NECase :: NExpr env (TEither a b) -> Var name1 a -> NExpr ('(name1, a) : env) c -> Var name2 b -> NExpr ('(name2, b) : env) c -> NExpr env c + NENothing :: STy t -> NExpr env (TMaybe t) + NEJust :: NExpr env t -> NExpr env (TMaybe t) + NEMaybe :: NExpr env b -> Var name t -> NExpr ('(name, t) : env) b -> NExpr env (TMaybe t) -> NExpr env b -- array operations NEConstArr :: Show (ScalRep t) => SNat n -> SScalTy t -> Array n (ScalRep t) -> NExpr env (TArr n (TScal t)) @@ -68,6 +71,10 @@ data NExpr env t where -> NExpr env a -> NExpr env b -> NExpr env t + -- accumulation effect on monoids + NEWith :: STy t -> NExpr env (D2 t) -> Var name (TAccum t) -> NExpr ('(name, TAccum t) : env) a -> NExpr env (TPair a (D2 t)) + NEAccum :: STy t -> SAcPrj p t a -> NExpr env (AcIdx p t) -> NExpr env (D2 a) -> NExpr env (TAccum t) -> NExpr env TNil + -- partiality NEError :: STy a -> String -> NExpr env a @@ -182,6 +189,9 @@ fromNamedExpr val = \case NEInl t e -> EInl ext t (go e) NEInr t e -> EInr ext t (go e) NECase e n1 a n2 b -> ECase ext (go e) (lambda val n1 a) (lambda val n2 b) + NENothing t -> ENothing ext t + NEJust e -> EJust ext (go e) + NEMaybe a n b c -> EMaybe ext (go a) (lambda val n b) (go c) NEConstArr n t x -> EConstArr ext n t x NEBuild k a n b -> EBuild ext k (go a) (lambda val n b) @@ -206,6 +216,9 @@ fromNamedExpr val = \case (fromNamedExpr (NTop `NPush` nr1 `NPush` nr2) c) (go e1) (go e2) + NEWith t a n b -> EWith ext t (go a) (lambda val n b) + NEAccum t p a b c -> EAccum ext t p (go a) (go b) (go c) + NEError t s -> EError ext t s NEUnnamed e args -> injectWrapLet (weakenExpr (wRaiseAbove args (envFromNEnv val)) e) args |