.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))))))

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

app/Main.hs

@@ -1,17 +1,12 @@
-{-# LANGUAGE RequiredTypeArguments #-}
+{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE TypeFamilies #-}
 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!"
 

cabal.project

@@ -2,6 +2,6 @@ packages: *.cabal
 
 source-repository-package
     type: git
-    location: https://git.deertopia.net/msyds/qbe-hs
+    location: https://git.deertopia.net/msyds/qbe-hs.git
-    tag: e03e918bf4d967edf73ce826d52b2d78832fa54e
+    tag: 25b62cb69d8e3bd51f32c4bfe494fa78094f8fc2
-    --sha256: 0dcjh8snaxpj28amn3i7hvdjbamqv5hzlibi2g3w66n8j08n9z6f
+    --sha256: 04w91dppjq44w50imw0ifj480ijkjy28428s3zyj39pmk6hlvkvz

flake.nix

@@ -30,15 +30,19 @@
           gyehoek = final.haskell-nix.project' {
             src = ./.;
             compiler-nix-name = "ghc912";
-            shell.tools = {
+            shell = {
+              withHoogle = true;
+              tools = {
                 cabal = {};
                 haskell-language-server = {};
               };
-            shell.buildInputs = with final; [
+              buildInputs = with final; [
                 gcc
                 qbe
+                haskellPackages.cabal-fmt
               ];
             };
+          };
         })
       ];
 
@@ -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} // {

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
+
 -- copyright:
 category:      Language
 build-type:    Simple
+
 -- extra-doc-files:    CHANGELOG.md
 -- extra-source-files:
 
-common warnings
+common ghcstuffs
-    ghc-options: -Wall
+  ghc-options:
-                 -fdefer-type-errors
+    -Wall -fdefer-type-errors -fno-show-valid-hole-fits
-                 -fno-show-valid-hole-fits
+    -fdefer-out-of-scope-variables -Wno-typed-holes
-                 -fdefer-out-of-scope-variables
-                 -Wno-typed-holes
     -fplugin=Effectful.Plugin
 
+  other-extensions:
+    BlockArguments
+    PartialTypeSignatures
+
 executable gyehoek
-    import:           warnings
+  import:           ghcstuffs
   main-is:          Main.hs
-    -- other-modules:
+
+  -- cabal-fmt: expand app -Main
+  other-modules:    Gyehoek.QBE
+
   -- other-extensions:
-    build-depends:    base ^>=4.21.2.0
+  build-depends:
-                    , lens
+    , base               ^>=4.21.2.0
-                    , text
-                    , recursion-schemes
     , effectful
     , effectful-core
     , effectful-plugin
+    , lens
+    , megaparsec
+    , prettyprinter
     , qbe
+    , recursion-schemes
+    , text
+
   hs-source-dirs:   app
   default-language: GHC2024