From 7495957f1b718355a141dd88bfe2de5631fd8fbc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Wed, 29 Apr 2026 20:05:53 -0600 Subject: [PATCH] --- .dir-locals.el | 5 ++ app/Gyehoek/QBE.hs | 199 +++++++++++++++++++++++++++++++++++++++++++++ app/Main.hs | 27 +----- cabal.project | 6 +- flake.nix | 19 +++-- gyehoek.cabal | 73 +++++++++-------- 6 files changed, 262 insertions(+), 67 deletions(-) create mode 100644 .dir-locals.el create mode 100644 app/Gyehoek/QBE.hs diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..545feef --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,5 @@ +((haskell-cabal-mode + . ((eval + . (progn (defun apply-cabal-fmt-h () + (haskell-mode-buffer-apply-command "cabal-fmt")) + (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)))))) diff --git a/app/Gyehoek/QBE.hs b/app/Gyehoek/QBE.hs new file mode 100644 index 0000000..8f12f8b --- /dev/null +++ b/app/Gyehoek/QBE.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE RequiredTypeArguments #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ApplicativeDo #-} +module Gyehoek.QBE + ( Unique + , runUnique + , unique + , module QBE + , render + ) + where + +import Language.QBE as QBE +import Effectful.State.Dynamic +import Effectful.Dispatch.Dynamic +import Effectful +import Numeric.Natural +import Data.String (IsString(fromString)) +import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions) +import Data.Text (Text) +import Prettyprinter.Render.Text (renderStrict) +import Text.Megaparsec +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer qualified as L +import Data.Void (Void) +import Data.Char (isAlpha, isAlphaNum) +import Control.Lens.Wrapped +import Data.Functor.Contravariant (Predicate(Predicate)) +import qualified Data.Text as T +import Data.Functor +import Data.List (List) +import Data.Foldable (fold) +import Data.Maybe (isJust, fromMaybe) +import Control.Monad.Fix (MonadFix(mfix)) + + +render :: Pretty a => a -> Text +render = renderStrict . layoutPretty defaultLayoutOptions . pretty + +data Unique :: Effect where + Unique :: Unique m (Ident s) + +type instance DispatchOf Unique = Dynamic + +unique :: forall s es. Unique :> es => Eff es (Ident s) +unique = send Unique + +runUnique :: Eff (Unique : es) a -> Eff es a +runUnique = reinterpret (evalStateLocal (0 :: Natural)) \_ Unique -> + state \n -> (Ident . fromString $ '.' : show n, succ n) + +-- class SigilChar (s :: Sigil) where +-- sigilChar' :: Proxy s -> Char +-- instance SigilChar AggregateTy where sigilChar' _ = ':' +-- instance SigilChar Global where sigilChar' _ = '$' +-- instance SigilChar Temporary where sigilChar' _ = '%' +-- instance SigilChar Label where sigilChar' _ = '@' + +-- sigilChar :: forall (s :: Sigil) -> SigilChar s => Char +-- sigilChar s = sigilChar' (Proxy @s) + + + +type P = Parsec Void Text + +sc :: P () +sc = L.space hspace1 (L.skipLineComment "#") empty + +lexeme :: P a -> P a +lexeme = L.lexeme sc + +symbol :: Text -> P Text +symbol = L.symbol sc + +infixr 8 .: +(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d +(.:) f g x y = f (g x y) + +rawIdent :: P QBE.RawIdent +rawIdent = (fromString .: (:) <$> lead <*> trail) "ident" + where + lead = satisfy \x -> isAlpha x || (x=='.') || (x=='_') + trail = fmap T.unpack . takeWhileP Nothing $ \x -> + isAlphaNum x || (x=='.') || (x=='_') + +class ParseIdent (s :: Sigil) where + ident :: P (QBE.Ident s) + +rawIdentWithSigil :: Char -> P (Ident t) +rawIdentWithSigil c = Ident <$> lexeme (char c *> rawIdent) + +instance ParseIdent AggregateTy where ident = rawIdentWithSigil ':' +instance ParseIdent Global where ident = rawIdentWithSigil '$' +instance ParseIdent Temporary where ident = rawIdentWithSigil '%' +instance ParseIdent QBE.Label where ident = rawIdentWithSigil '@' + +const :: P QBE.Const +const = cint <|> csingle <|> cdouble <|> cglobal "const" + where + cint = CInt <$> lexeme (L.signed empty L.decimal) "integer" + csingle = empty "single-precision float" + cdouble = empty "double-precision float" + cglobal = CGlobal <$> ident "global symbol" + +val :: P QBE.Val +val = vconst <|> vtemp "val" + where + vconst = ValConst <$> Gyehoek.QBE.const + vtemp = ValTemporary <$> ident "temporary symbol" + +assignment :: P QBE.Assignment +assignment = + Assignment <$> ident <*> (char '=' *> basety) + +basety :: P QBE.BaseTy +basety = lexeme $ char 'w' $> Word + <|> char 'l' $> Long + <|> char 's' $> Single + <|> char 'd' $> Double + +abity :: P AbiTy +abity = AbiBaseTy <$> basety + <|> AbiAggregateTy <$> ident + +binaryOp :: P QBE.BinaryOp +binaryOp = lexeme $ "add" $> Add + <|> "sub" $> Sub + <|> "mul" $> Mul + <|> "div" $> Div Signed + +comma :: P a -> P a +comma p = symbol "," *> p + +inst :: P QBE.Inst +inst = try binaryOpInst <|> negInst "inst" + where + binaryOpInst = + BinaryOp + <$> assignment + <*> binaryOp + <*> val <*> comma val + negInst = Neg <$> assignment <*> (symbol "neg" *> val) + +jump :: P QBE.Jump +jump = jmp <|> jnz <|> ret <|> hlt "jump" + where + jmp = symbol "jmp" *> (Jmp <$> ident) + jnz = symbol "jnz" *> (Jnz <$> val <*> ident <*> comma ident) + ret = symbol "ret" *> (Ret <$> optional val) + hlt = empty + +nl :: P () +nl = void (some (newline *> sc)) "newline" + +phi :: P QBE.Phi +phi = empty + +block :: P QBE.Block +block = Block + <$> (ident <* nl) + <*> sepBy phi nl + <*> sepBy inst nl + <*> jump + +sepByTry :: MonadParsec e s m => m a -> m sep -> m (List a) +sepByTry p sep = do + x <- p + xs <- many (try $ sep *> p) + pure (x:xs) + +params :: P (Maybe (Ident Temporary), List Param, Variadic) +params = between (symbol "(") (symbol ")") do + e <- optional env + ps <- optional . try $ do + commaIf (isJust e) + sepByTry reg (symbol ",") + v <- optional do + commaIf (isJust e || isJust ps) + variadic + pure (e, fromMaybe [] ps, fromMaybe NoVariadic v) + where + continue d m = fromMaybe d <$> optional (symbol "," *> m) + commaIf True = void $ symbol "," + commaIf False = pure () + env = symbol "env" *> ident @Temporary "environment parameter" + reg = Param <$> abity <*> ident "regular parameter" + variadic = symbol "..." $> Variadic "variadic parameter" + +funcdef :: P QBE.FuncDef +funcdef = do + linkages <- _ + symbol "function" + returnTy <- optional abity + name <- ident @Global + (env,params,variadic) <- params + code <- _ + pure $ FuncDef linkages returnTy name env params variadic code diff --git a/app/Main.hs b/app/Main.hs index 078d23b..8ef68a0 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,17 +1,12 @@ -{-# LANGUAGE RequiredTypeArguments #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BlockArguments #-} module Main (main) where -import Language.QBE -import Data.Text qualified as T import Data.Text (Text) -import Effectful.State.Static.Local import Effectful +import Gyehoek.QBE import Data.List (List) -import Data.Proxy (Proxy (Proxy)) -import GHC.TypeLits type Name = Text @@ -27,24 +22,6 @@ data Expr data Prim = PrimAdd | PrimSub | PrimMul | PrimDiv deriving (Show) -type Unique = State Int - -type family SigilChar (s :: Sigil) :: Char where - SigilChar AggregateTy = ':' - SigilChar Global = '$' - SigilChar Temporary = '%' - SigilChar Label = '@' - -hmm :: forall (s :: Sigil). Proxy s -> Proxy (SigilChar s) -hmm Proxy = Proxy - -sigilChar :: forall (s :: Sigil). Proxy s -> Char --- sigilChar x = charVal (hmm x) -sigilChar x = _ - -unique :: forall s es. (Unique :> es) => Eff es (Ident s) -unique = _ - main :: IO () main = putStrLn "Hello, Haskell!" diff --git a/cabal.project b/cabal.project index d9a8799..13e43fb 100644 --- a/cabal.project +++ b/cabal.project @@ -2,6 +2,6 @@ packages: *.cabal source-repository-package type: git - location: https://git.deertopia.net/msyds/qbe-hs - tag: e03e918bf4d967edf73ce826d52b2d78832fa54e - --sha256: 0dcjh8snaxpj28amn3i7hvdjbamqv5hzlibi2g3w66n8j08n9z6f + location: https://git.deertopia.net/msyds/qbe-hs.git + tag: 25b62cb69d8e3bd51f32c4bfe494fa78094f8fc2 + --sha256: 04w91dppjq44w50imw0ifj480ijkjy28428s3zyj39pmk6hlvkvz diff --git a/flake.nix b/flake.nix index 1594ab1..3722524 100644 --- a/flake.nix +++ b/flake.nix @@ -30,14 +30,18 @@ gyehoek = final.haskell-nix.project' { src = ./.; compiler-nix-name = "ghc912"; - shell.tools = { - cabal = {}; - haskell-language-server = {}; + shell = { + withHoogle = true; + tools = { + cabal = {}; + haskell-language-server = {}; + }; + buildInputs = with final; [ + gcc + qbe + haskellPackages.cabal-fmt + ]; }; - shell.buildInputs = with final; [ - gcc - qbe - ]; }; }) ]; @@ -61,6 +65,7 @@ in { # Exposed as a REPL convenience. _pkgs = each-system ({ pkgs, ... }: pkgs); + _hf = hf; packages = each-system ({ pkgs, system, ... }: hf.packages.${system} // { diff --git a/gyehoek.cabal b/gyehoek.cabal index 54a522a..7b2af14 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -1,38 +1,47 @@ -cabal-version: 3.0 -name: gyehoek -version: 0.1.0.0 --- synopsis: --- description: -license: BSD-3-Clause -license-file: LICENSE -author: Madeleine Sydney Ślaga -maintainer: msyds@deertopia.net +cabal-version: 3.0 +name: gyehoek +version: 0.1.0.0 +license: BSD-3-Clause +license-file: LICENSE +author: Madeleine Sydney Ślaga +maintainer: msyds@deertopia.net + -- copyright: -category: Language -build-type: Simple +category: Language +build-type: Simple + -- extra-doc-files: CHANGELOG.md -- extra-source-files: -common warnings - ghc-options: -Wall - -fdefer-type-errors - -fno-show-valid-hole-fits - -fdefer-out-of-scope-variables - -Wno-typed-holes - -fplugin=Effectful.Plugin +common ghcstuffs + ghc-options: + -Wall -fdefer-type-errors -fno-show-valid-hole-fits + -fdefer-out-of-scope-variables -Wno-typed-holes + -fplugin=Effectful.Plugin + + other-extensions: + BlockArguments + PartialTypeSignatures executable gyehoek - import: warnings - main-is: Main.hs - -- other-modules: - -- other-extensions: - build-depends: base ^>=4.21.2.0 - , lens - , text - , recursion-schemes - , effectful - , effectful-core - , effectful-plugin - , qbe - hs-source-dirs: app - default-language: GHC2024 + import: ghcstuffs + main-is: Main.hs + + -- cabal-fmt: expand app -Main + other-modules: Gyehoek.QBE + + -- other-extensions: + build-depends: + , base ^>=4.21.2.0 + , effectful + , effectful-core + , effectful-plugin + , lens + , megaparsec + , prettyprinter + , qbe + , recursion-schemes + , text + + hs-source-dirs: app + default-language: GHC2024