diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index 45fa649..61c821f 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OrPatterns #-} @@ -17,6 +19,11 @@ module Gyehoek.Scheme.Syntax , CommandOrDef(..) , primSexpIso , pattern Void + , free + , qexp + , qprog + , subst + , freeVariables ) where @@ -37,11 +44,17 @@ import Control.Lens import Data.String (IsString) import Data.Hashable (Hashable) import Control.Lens.Unsound (prismSum) +import Data.Data (Data) +import Data.Functor.Foldable.TH (makeBaseFunctor) +import Data.Functor.Foldable hiding (fold) +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS +import Data.Foldable (fold) newtype Name = MkName { getName :: Text } deriving newtype (Show, Eq, IsString, Gen, Hashable) - deriving stock (Generic) + deriving stock (Generic, Data) data Prim e = PrimAdd e e @@ -57,7 +70,7 @@ data Prim e | PrimWrite e | PrimZeroP e | PrimNewline - deriving (Show, Generic, Functor, Foldable, Traversable) + deriving (Show, Generic, Functor, Foldable, Traversable, Data) instance Each (Prim e) (Prim e') e e' @@ -67,7 +80,7 @@ data Lit | LitBool Bool | LitString Text | LitQuote Sexp - deriving (Show, Generic) + deriving (Show, Generic, Data) pattern Void :: Lit pattern Void = LitNil @@ -75,7 +88,7 @@ pattern Void = LitNil data Def = DefConstant Name Exp | DefProcedure Name (List Name) (List Exp) - deriving (Show, Generic) + deriving (Show, Generic, Data) data Exp = ExpLet (NonEmpty (Name, Exp)) Exp @@ -86,24 +99,24 @@ data Exp | ExpLambda (List Name) Exp | ExpVar Name | ExpApply Exp (List Exp) - deriving (Show, Generic) + deriving (Show, Generic, Data) data Sexp = SexpCons Sexp Sexp | SexpSymbol Text | SexpLit Lit - deriving (Show, Generic) + deriving (Show, Generic, Data) data CommandOrDef = Command Exp | Definition Def | Begin (List CommandOrDef) - deriving (Show, Generic) + deriving (Show, Generic, Data) data Program = MkProgram { commandsAndDefs :: List CommandOrDef } - deriving (Show, Generic) + deriving (Show, Generic, Data) instance Each Program Program (Either Exp Def) (Either Exp Def) where each = #commandsAndDefs . each . go @@ -116,6 +129,8 @@ instance Each Program Program (Either Exp Def) (Either Exp Def) where go k (Definition d) = inj <$> k (Right d) go k (Begin xs) = Begin <$> traverse (go k) xs +makeBaseFunctor ''Exp + instance SexpIso Name where @@ -211,3 +226,41 @@ instance SexpIso CommandOrDef where $ End where bgn = list $ el (sym "begin") >>> rest sexpIso + + +-- utilities + +qexp = Gyehoek.Sexp.makeSx $ sexpIso @Exp +qprog = Gyehoek.Sexp.makeSxs (sexpIso @CommandOrDef) MkProgram + +free :: Exp -> HashSet Name +free = cata \case + ExpVarF x -> HS.singleton x + ExpLetF bs e -> error "todo lol" + ExpLambdaF binders vs -> deleteFrom binders vs + e -> fold e + +deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a +deleteFrom = flip $ foldr HS.delete + +insertFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a +insertFrom = flip $ foldr HS.insert + +subst :: (Name -> Maybe Exp) -> Exp -> Exp +subst f = \e -> cata go e mempty where + go (ExpVarF x) bound + | not (x `HS.member` bound), Just e' <- f x = e' + | otherwise = ExpVar x + go (ExpLetF _ _) _ = error "todo lol" + go (ExpLambdaF bs e) bound = e $ insertFrom bs bound + go e bound = embed $ fmap ($ bound) e + +-- | Unlawful! +freeVariables :: Traversal Exp Exp Name Exp +freeVariables k = \e -> cataA go e mempty where + go (ExpVarF x) bound + | not (x `HS.member` bound) = k x + | otherwise = pure $ ExpVar x + go (ExpLetF _ _) _ = error "todo lol" + go (ExpLambdaF bs e) bound = e $ insertFrom bs bound + go e bound = embed <$> traverse ($ bound) e diff --git a/src/Gyehoek/Sexp.hs b/src/Gyehoek/Sexp.hs index b9f736e..91ca7fb 100644 --- a/src/Gyehoek/Sexp.hs +++ b/src/Gyehoek/Sexp.hs @@ -4,6 +4,8 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE OrPatterns #-} module Gyehoek.Sexp ( let_ , sexp @@ -25,11 +27,18 @@ module Gyehoek.Sexp , encodePretty , UglySexpIso(..) , AsSexpIso(..) + , parseSexpsWithPos + , parseSexpWithPos + , parseSexp + , sx + , sxs + , makeSx + , makeSxs ) where import Data.Text (Text) -import Language.SexpGrammar as Sexp hiding (List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty) +import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty) import Language.SexpGrammar qualified as Sexp import Language.Sexp qualified as S import Language.SexpGrammar.Generic @@ -37,7 +46,8 @@ import Data.InvertibleGrammar.Base qualified as IGB import Data.InvertibleGrammar qualified as IG import Data.InvertibleGrammar.Base ((:-)((:-))) import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.List (List) +import Data.List.NonEmpty qualified as NE +import Data.List (List, groupBy) import Data.Text.Encoding import Data.Either (either) import GHC.Generics (Generic) @@ -47,10 +57,16 @@ import System.Process import GHC.IO.Unsafe (unsafePerformIO) import qualified Data.Text.IO as TIO import Control.Monad (join) -import qualified Language.Sexp.Located as SexpLoc +import qualified Language.Sexp.Located as SL import Data.Void (absurd, Void) import Data.Coerce (coerce) import qualified Data.Map +import Language.Haskell.TH.Quote +import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, conE) +import qualified Data.Text as T +import qualified Control.Category +import Data.Data (Data, Typeable, cast) +import Language.Haskell.TH.Syntax (lift, Lift) sexp :: SexpIso a => Iso' a Text @@ -78,9 +94,23 @@ encodePrettyWith g = (_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a) -parseSexps f = marshal . SexpLoc.parseSexps f . view lazy . encodeUtf8 +parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8 where marshal = join . traverseOf (_Right . each) (fromSexp sexpIso) +parseSexp :: SexpIso a => FilePath -> Text -> Either String a +parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8 + where marshal = join . traverseOf _Right (fromSexp sexpIso) + +parseSexpsWithPos :: SexpGrammar a -> Position -> Text -> Either String (List a) +parseSexpsWithPos g pos = + marshal . SL.parseSexpsWithPos pos . view lazy . encodeUtf8 + where marshal = join . traverseOf (_Right . each) (fromSexp g) + +parseSexpWithPos :: SexpGrammar a -> Position -> Text -> Either String a +parseSexpWithPos g pos = + marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8 + where marshal = join . traverseOf _Right (fromSexp g) + nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t) nonEmptyGrammar = IGB.Iso (\((x:|xs) :- t) -> reverse xs :- x :- t) @@ -183,3 +213,118 @@ instance UglySexpIso Int where uglySexpIso = sexpIso instance UglySexpIso Bool where uglySexpIso = sexpIso instance UglySexpIso Double where uglySexpIso = sexpIso instance UglySexpIso () where uglySexpIso = sexpIso + +instance SexpIso Sexp where + sexpIso = Control.Category.id + +-- evil ass orphan instances +deriving instance (Data a, Data e) => Data (SL.LocatedBy a e) +deriving instance Data SL.Atom +deriving instance Data SL.Prefix +deriving instance Data SL.Position +deriving instance (Data e) => Data (SL.SexpF e) + + +-- Quasiquoter + +getPos = do + Loc {loc_filename,loc_start} <- location + pure $ SL.Position loc_filename (fst loc_start) (snd loc_start) + +makeSxs :: Data b => SexpGrammar a -> (List a -> b) -> QuasiQuoter +makeSxs g f = QuasiQuoter + { quoteExp = \str -> do + pos <- getPos + case parseSexpsWithPos g pos (T.pack str) of + Left e -> fail e + Right xs -> dataToExpQ (const Nothing) (f xs) + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } + +toSexp :: SexpIso a => a -> Sexp +toSexp = either error id . Sexp.toSexp sexpIso + +pattern Unquote x = + SL.Modified Hash (SL.BraceList [SL.Symbol x]) +pattern UnquoteSplicing x = + SL.Modified Hash (SL.Modified Hash (SL.BraceList [SL.Symbol x])) + +_UnquoteSplicing :: Prism' Sexp.Sexp Text +_UnquoteSplicing = prism' + UnquoteSplicing + (\case { UnquoteSplicing x -> Just x ; _ -> Nothing }) + +instance Each Sexp Sexp Sexp Sexp where + each k (SL.ParenList xs) = SL.ParenList <$> traverse k xs + each k (SL.BracketList xs) = SL.BracketList <$> traverse k xs + each k (SL.BraceList xs) = SL.BraceList <$> traverse k xs + each _ e@(SL.Atom _; SL.Modified _ _) = pure e + +metaSexp :: Sexp.Sexp -> Maybe ExpQ +metaSexp (Unquote x) = + Just [| toSexp $(varE (mkName (T.unpack x))) |] +metaSexp (SL.ParenList xs) + | (_:_) <- xs ^.. each . _UnquoteSplicing + = Just [| SL.ParenList (mconcat $(listE spans)) |] + where + spans = xs + & groupBy \cases + (UnquoteSplicing _) _ -> False + _ (UnquoteSplicing _) -> False + _ _ -> True + & fmap \case + [UnquoteSplicing x] -> varE (mkName (T.unpack x)) + x -> lift x +metaSexp _ = Nothing + +-- 뻘짓뻘짓뻘짓뻘짓뻘짓 +class Lift1 f where + liftLift :: Quote m => (a -> m Exp) -> f a -> m Exp + +lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp +lift1 = liftLift lift + +instance Lift1 f => Lift (SL.Fix f) where + lift (SL.Fix inner) = appE [|Fix|] (lift1 inner) + +instance (Lift1 f, Lift1 g) => Lift1 (SL.Compose f g) where + liftLift l (SL.Compose fga) = [|Compose $(liftLift (liftLift l) fga)|] + +instance Lift a => Lift1 (SL.LocatedBy a) where + liftLift l (a SL.:< e) = [|(SL.:<) $(lift a) $(l e)|] + +instance Lift1 List where + liftLift l xs = listE $ l <$> xs + +instance Lift1 SL.SexpF where + liftLift l = \case + SL.AtomF a -> [|SL.AtomF $(lift a)|] + SL.ParenListF es -> [|SL.ParenListF $(liftLift l es)|] + SL.BracketListF es -> [|SL.BracketListF $(liftLift l es)|] + SL.BraceListF es -> [|SL.BraceListF $(liftLift l es)|] + SL.ModifiedF p e -> [|SL.Modified $(lift p) $(l e)|] + +-- deriving instance Lift a => Lift (SL.SexpF a) +deriving instance Lift SL.Atom +deriving instance Lift SL.Position +deriving instance Lift SL.Prefix + +extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r +extQ f g a = maybe (f a) g (cast a) + +makeSx :: Data a => SexpGrammar a -> QuasiQuoter +makeSx g = QuasiQuoter + { quoteExp = \str -> do + pos <- getPos + case parseSexpWithPos g pos (T.pack str) of + Left e -> fail e + Right x -> dataToExpQ (const Nothing `extQ` metaSexp) x + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } + +sxs = makeSxs (sexpIso @Sexp) id +sx = makeSx (sexpIso @Sexp) diff --git a/src/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs index 3a42084..3b6d084 100644 --- a/src/Gyehoek/Wasm.hs +++ b/src/Gyehoek/Wasm.hs @@ -11,43 +11,7 @@ {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE DerivingVia #-} module Gyehoek.Wasm - ( defun - , rec' - , start - , runGenMod - , execGenMod - , renderModule - , Module - , Function - , Type(..) - , Expr - , Instr - , GenMod - , Idx - , i32 - , export - , ins - , sxp - , result - , param - , if' - , ref - , eq - , i31ref - , i31 - , struct - , mut - , sub - , deftype - , namedType - , type' - , deftypeNamed - , defglobal - , array - , FromIdx(..) - , func - , refnull - , declareFuncref + ( Module ) where @@ -83,344 +47,30 @@ import qualified Control.Category import Data.Functor (void) -data Module = MkModule - { types :: Vector RecType - , functions :: Vector Function - , funcrefs :: Vector Funcref - , start :: Maybe Idx - , exports :: Vector Export - , globals :: Vector Global - } - deriving (Show, Generic) - -instance Semigroup Module where - m1 <> m2 = MkModule - { types = m1.types <> m2.types - , functions = m1.functions <> m2.functions - , start = m2.start <|> m1.start - , exports = m1.exports <> m2.exports - , funcrefs = m1.funcrefs <> m2.funcrefs - , globals = m1.globals <> m2.globals - } - -instance Monoid Module where - mempty = MkModule mempty mempty mempty Nothing mempty mempty - -newtype Funcref = MkFuncref { inner :: Idx } - deriving (Show, Generic) - -data Global = MkGlobal - { ty :: Type - , body :: Expr - } - deriving (Show, Generic) - -newtype RecType = MkRecType { inner :: Vector Type } - deriving (Show, Generic) - -data Function = MkFunction - { params :: List Type - , result :: List Type - , locals :: List Type - , body :: Expr - } - deriving (Show, Generic) - -newtype Export = MkExport { inner :: Sexp } - deriving (Show, Generic) - -newtype Expr = MkExpr { inner :: Vector Instr } +newtype Module = MkModule { inner :: Vector Sexp } deriving (Show, Generic) deriving newtype (Semigroup, Monoid) -newtype Instr = MkInstr { inner :: Sexp } +newtype Expr = MkExpr { inner :: Vector Sexp } deriving (Show, Generic) + deriving newtype (Semigroup, Monoid) -newtype Type = MkType { inner :: Sexp } - deriving (Show, Generic) +newtype Idx = MkIdx { inner :: Natural } + deriving (Generic) + deriving newtype (Show) -data Idx - = IdxNumeric Natural - | IdxNamed Text + +-- GenMod + +-- | 'GenModState' is a 'Module' paired with the numbers of functions, +-- types, globals, etc. defined in the module. +data GenModState = MkGenModState + { mod :: Module + , funcs :: Natural + , types :: Natural + } deriving (Show, Generic) data GenMod :: Effect where - DefRecType :: List Type -> GenMod m (List Idx) - Defun :: List Type -> List Type -> List Type - -> (Idx -> m Expr) -> GenMod m Idx - Start :: Idx -> GenMod m () - Export :: Text -> Text -> Idx -> GenMod m () - DefGlobal :: Type -> Expr -> GenMod m Idx - DeclareFuncref :: Idx -> GenMod m () - -type instance DispatchOf GenMod = Dynamic - -export :: (GenMod :> es) => Text -> Text -> Idx -> Eff es () -export name ty idx = send $ Export name ty idx - -start :: (GenMod :> es) => Idx -> Eff es () -start = send . Start - -rec' :: (GenMod :> es) => List Type -> Eff es (List Idx) -rec' = send . DefRecType - -deftype :: (GenMod :> es) => Type -> Eff es Idx -deftype (MkType t) = send (DefRecType [type' t]) <&> \case - [x] -> x - x -> error $ "unreachable " <> show x - -deftypeNamed :: (GenMod :> es) => Text -> Type -> Eff es () -deftypeNamed name (MkType t) = void $ send (DefRecType [namedType name t]) - -defglobal :: (GenMod :> es) => Type -> Expr -> Eff es Idx -defglobal t e = send $ DefGlobal t e - -defun - :: (GenMod :> es) - => List Type -> List Type -> List Type - -> (Idx -> Eff es Expr) - -> Eff es Idx -defun params res locals code = send $ Defun params res locals code - -declareFuncref :: GenMod :> es => Idx -> Eff es () -declareFuncref = send . DeclareFuncref - --- defun --- :: (GenMod :> es) --- => List Type -> List Type -> List Type --- -> (Idx -> Eff '[GenExp] a) --- -> Eff es Idx --- defun params result locals code = --- send $ Defun params result locals (runPureEff . execWriterLocal . code) - -runGenMod :: forall es a. Eff (GenMod : es) a -> Eff es (a, Module) -runGenMod = - reinterpret (runStateLocal (mempty :: Module)) \cases - _ (DefRecType ts) -> state \m -> - ( let prev_n = sumOf (#types . each . #inner . to V.length) m - in IdxNumeric . fromIntegral <$> [prev_n .. prev_n + length ts - 1] - , m & #types <>~ V.singleton (MkRecType (V.fromList ts)) - ) - _ (Start idx) -> assign #start (Just idx) - _ (Export name ty idx) -> - #exports <>= V.singleton e - where e = MkExport $ ParenList - [ "export", sxp name, ParenList [ "func", sxp idx ] ] - env (Defun params result locals code) -> - localSeqUnlift env \unlift -> do - m <- get - -- the least unused function index, computed as the number - -- of currently allocated functions. - let idx = IdxNumeric . fromIntegral . length $ m.functions - -- the body is computed with access to the newly allocated - -- index `idx` for the sake of recursive occurences. - body <- unlift $ code idx - let func = MkFunction {params,result,locals,body} - #functions <>= V.singleton func - pure idx - _ (DefGlobal t e) -> state \m -> - let prev_n = IdxNumeric . fromIntegral . V.length $ m.globals - m' = m & #globals <>~ V.singleton (MkGlobal t e) - in (prev_n, m') - _ (DeclareFuncref idx) -> #funcrefs <>= V.singleton (MkFuncref idx) - -execGenMod = fmap snd . runGenMod - -renderModule :: Module -> Text -renderModule = (^?! _Right) . Gyehoek.Sexp.encodePretty - -ref :: Type -> Type -ref (MkType x) = MkType . ParenList $ [Symbol "ref", x] - -refnull :: Type -> Type -refnull (MkType x) = MkType . ParenList $ ["ref", "null", x] - -sub :: List Idx -> Type -> Type -sub supers (MkType x) = MkType . ParenList $ - Symbol "sub" : (sxp <$> supers) ++ [x] - -array :: Type -> Type -array (MkType x) = MkType . ParenList $ [Symbol "array", x] - -mut :: Type -> Type -mut (MkType x) = MkType . ParenList $ [Symbol "mut", x] - -struct :: List Type -> Type -struct xs = MkType . ParenList $ - Symbol "struct" : (xs ^.. each . #inner . to field) - where field x = ParenList [Symbol "field", x] - -func :: List Type -> List Type -> Type -func params results = - MkType . ParenList $ - [ Symbol "func" - , wrap "param" params - , wrap "result" results - ] - where - wrap s xs = ParenList $ Symbol s : xs ^.. each . #inner - -i32, i31ref, eq, i31 :: Type -i32 = MkType $ Symbol "i32" -i31ref = MkType $ Symbol "i31ref" -eq = MkType $ Symbol "eq" -i31 = MkType $ Symbol "i31" - -class FromIdx a where - fromIdx :: Idx -> a - -instance FromIdx Type where - fromIdx (IdxNumeric n) = MkType . Symbol . T.pack . show $ n - - - -instance SexpIso Idx where - sexpIso = match - $ With (\numeric -> num >>> numeric) - $ With (\named -> name >>> named) - $ End - where - num = Sexp.integer >>> Sexp.partialOsi f g - where - f n | n < 0 = Left $ Sexp.unexpected "negative" - <> Sexp.expected "natural" - | otherwise = Right $ fromIntegral n - g n = fromIntegral n - l :: Prism' Text Text - l = prefixed "$" - name = Sexp.symbol >>> Sexp.partialOsi - (maybe (Left $ Sexp.expected "$-prefixed sym") Right . preview l) - (review l) - -instance SexpIso RecType where - sexpIso = with \rectype -> - Sexp.coproduct - [ sexpIso @Type >>> Sexp.partialIso - (\x -> [x]) - (\case [x] -> Right x - _ -> Left $ Sexp.expected "a single type") - , list (el (sym "rec") >>> rest sexpIso) - ] - >>> Sexp.iso V.fromList V.toList - >>> rectype - -- where - -- typedef - -- :: forall a t. Sexp.Grammar Position (Sexp :- t) (a :- t) - -- -> Sexp.Grammar Position (Sexp :- t) (a :- t) - -- typedef x = list (el (sym "type") >>> el x) - -type' :: Sexp -> Type -type' e = MkType . ParenList $ [ "type", e ] - -namedType :: Text -> Sexp -> Type -namedType name e = MkType . ParenList $ [ "type", Symbol name, e ] - -instance SexpIso Global where - sexpIso = with \glob -> - list ( el (sym "global") - >>> el (sexpIso @Type) - >>> restCode - ) - >>> glob - -instance SexpIso Instr where - sexpIso = Sexp.iso coerce coerce - -instance SexpIso Type where - sexpIso = Sexp.iso coerce coerce - -instance SexpIso Export where - sexpIso = Sexp.iso coerce coerce - -restCode :: Sexp.Grammar Position (Sexp.List :- t) (Sexp.List :- (Expr :- t)) -restCode = - rest (sexpIso @Instr) - >>> Sexp.onTail - (Sexp.iso - (view instrsExpr) - (review instrsExpr)) - where - instrsExpr :: Iso' (List Instr) Expr - instrsExpr = vector . coerced - -instance SexpIso Function where - sexpIso = with \func -> - list ( el (sym "func") - >>> el (list $ el (sym "param") >>> rest (sexpIso @Type)) - >>> el (list $ el (sym "result") >>> rest (sexpIso @Type)) - >>> el (list $ el (sym "local") >>> rest (sexpIso @Type)) - >>> restCode - ) - >>> func - -instance SexpIso Module where - sexpIso = Sexp.partialOsi (const $ Left mempty) \m -> - ParenList $ - [ Symbol "module" ] - <> (m ^.. #types . each . to sxp) - <> (m ^.. #globals . each . to sxp) - <> (m ^.. #funcrefs . each . to sxp) - <> (m ^.. #functions . each . to sxp) - <> (m ^.. #exports . each . to sxp) - -instance SexpIso Funcref where - sexpIso = with \funcref -> - list ( el (sym "elem") - >>> el (sym "declare") - >>> el (sym "funcref") - >>> el (list $ el (sym "ref.func") >>> el (sexpIso @Idx)) - ) - >>> funcref - -instance SexpIso Sexp where - sexpIso = Control.Category.id - -instance Each Expr Expr Instr Instr where - each = #MkExpr . each - -sxp :: HasCallStack => SexpIso a => a -> Sexp -sxp e = either error id . Sexp.toSexp sexpIso $ e - -ins :: Text -> List Sexp -> Expr -ins op [] = [ MkInstr $ Symbol op ] -ins op xs = [ MkInstr . ParenList $ Symbol op : xs ] - -instance IsString Sexp where - fromString = Symbol . T.pack - -instance IsList Expr where - type Item Expr = Instr - fromList = MkExpr . V.fromList - toList e = V.toList e.inner - -data ResultType = MkResultType - { params :: List Type - , result :: List Type - } - deriving stock (Generic) - deriving (Semigroup, Monoid) - via Generically ResultType - -param :: List Type -> ResultType -param ts = MkResultType ts mempty - -result :: List Type -> ResultType -result ts = MkResultType mempty ts - -resultTypeSexp :: ResultType -> List Sexp -resultTypeSexp rt = - f "param" (coerce <$> rt.params) <> f "result" (coerce <$> rt.result) - where - f :: Text -> List Sexp -> List Sexp - f _ [] = [] - f kw s = [ ParenList $ Symbol kw : s ] - --- resultSexp :: ResultType -> Sexp --- resultSexp rt = ParenList $ Symbol "param" : (coerce <$> rt.result) - -if' :: ResultType -> Expr -> Expr -> Expr -if' rt t f = MkExpr . V.singleton . MkInstr . ParenList $ - [ Symbol "if" ] - <> resultTypeSexp rt - <> [ ParenList $ Symbol "then" : (t ^.. each . to sxp) ] - <> [ ParenList $ Symbol "else" : (f ^.. each . to sxp) ] + DefineFunction :: Sexp -> GenMod m Idx + DefineType :: Sexp -> GenMod m Idx