Updated to use GHC 9.4.x and floating dependencies

6 files changed, 63 insertions, 57 deletions

diff --git a/cabal.project b/cabal.project
new file mode 100644
index 0000000..2680722
--- /dev/null
+++ b/cabal.project
@@ -0,0 +1,3 @@
+packages: .
+
+with-compiler: ghc-9.4
diff --git a/micro.cabal b/micro.cabal
index b62f751..ec4cac6 100644
--- a/micro.cabal
+++ b/micro.cabal
@@ -26,13 +26,18 @@ library
         Micro.Compiler
         Micro.Asm.Sdcc
     build-depends:
-        base ^>= 4.16.1.0
-        , parsec ^>= 3.1.15.1
-        , mtl ^>= 2.2.2
-        , containers ^>= 0.6.5.1
+        base
+        , parsec
+        , mtl
+        , containers
     hs-source-dirs:   src
-    ghc-options:      -Wall -Wno-name-shadowing
-    default-language: Haskell2010
+    ghc-options:      -Wall -Wno-name-shadowing -Werror -O2 -j
+    default-extensions:
+        OverloadedStrings
+        OverloadedRecordDot
+        DuplicateRecordFields
+        NoFieldSelectors
+    default-language:  GHC2021
 
 test-suite tests
     type: exitcode-stdio-1.0
@@ -40,22 +45,22 @@ test-suite tests
     other-modules:
         Language
     build-depends:
-        base ^>= 4.16.1.0
-        , parsec ^>= 3.1.15.1
-        , mtl ^>= 2.2.2
-        , containers ^>= 0.6.5.1
+        base
+        , parsec
+        , mtl
+        , containers
         , HUnit
         , micro
     hs-source-dirs:   test
-    default-language: Haskell2010
+    default-language: GHC2021
 
 executable micro
     main-is:          Main.hs
     build-depends:
-        base ^>= 4.16.1.0
-        , containers ^>= 0.6.5.1
-        , mtl ^>= 2.2.2
+        base
+        , containers
+        , mtl
         , micro
     hs-source-dirs:   app
-    default-language: Haskell2010
+    default-language: GHC2021
 
diff --git a/src/Micro/Asm/Sdcc.hs b/src/Micro/Asm/Sdcc.hs
index af4e7d7..9d94b16 100644
--- a/src/Micro/Asm/Sdcc.hs
+++ b/src/Micro/Asm/Sdcc.hs
@@ -1,6 +1,6 @@
 module Micro.Asm.Sdcc where
 
-import qualified Micro.Ast as A
+import Micro.Ast qualified as A
 import Text.Parsec (SourcePos, sourceColumn, sourceLine)
 
 toIdent :: A.Ident -> String
@@ -46,14 +46,14 @@ mul8 :: A.Expr -> A.Expr -> SourcePos -> [String]
 mul8 a b p = do
   let loop = posToIdent p
   let loop0 = loop ++ "z"
-  oCode (emit a)
+  (emit a).oCode
     ++ [ "\tor a",
          "\tjr z, " ++ toIdent loop0,
          "\tld b, a",
          "\tdec b",
          "\tjr z, " ++ toIdent loop0
        ]
-    ++ oCode (emit b)
+    ++ (emit b).oCode
     ++ [ "\tld c, a",
          toLabel loop True,
          "\tadd c",
@@ -64,12 +64,12 @@ mul8 a b p = do
 
 mul :: A.Expr -> A.Expr -> SourcePos -> [String]
 mul a b@(A.Num v _) p
-  | v == 2 = oCode (emit a) ++ ["\tsla a"]
-  | v == 4 = oCode (emit a) ++ replicate 2 "\tsla a"
-  | v == 8 = oCode (emit a) ++ replicate 3 "\tsla a"
-  | v == 16 = oCode (emit a) ++ replicate 4 "\tsla a"
-  | v == 32 = oCode (emit a) ++ replicate 5 "\tsla a"
-  | v < 6 = oCode (emit a) ++ ["\tld c, a"] ++ replicate (fromInteger v - 1) "\tadd c"
+  | v == 2 = (emit a).oCode ++ ["\tsla a"]
+  | v == 4 = (emit a).oCode ++ replicate 2 "\tsla a"
+  | v == 8 = (emit a).oCode ++ replicate 3 "\tsla a"
+  | v == 16 = (emit a).oCode ++ replicate 4 "\tsla a"
+  | v == 32 = (emit a).oCode ++ replicate 5 "\tsla a"
+  | v < 6 = (emit a).oCode ++ ["\tld c, a"] ++ replicate (fromInteger v - 1) "\tadd c"
   | otherwise = mul8 a b p
 mul _ _ _ = [";; unimplemented"]
 
@@ -98,28 +98,28 @@ emit x =
     (A.BinOp A.Mul _ (A.Num a _) (A.Num b _)) -> o {oCode = [show a ++ "*" ++ show b]}
     (A.BinOp A.Div _ (A.Num a _) (A.Num b _)) -> o {oCode = [show a ++ "/" ++ show b]}
     (A.BinOp A.Plus _ a (A.Num 1 _)) ->
-      o {oCode = oCode (emit a) ++ ["\tinc a"]}
+      o {oCode = (emit a).oCode ++ ["\tinc a"]}
     (A.BinOp A.Plus _ a (A.Num v _)) ->
-      o {oCode = oCode (emit a) ++ ["\tadd #" ++ show v]}
+      o {oCode = (emit a).oCode ++ ["\tadd #" ++ show v]}
     (A.BinOp A.Plus _ a b) ->
-      o {oCode = oCode (emit a) ++ ["\tld c, a"] ++ oCode (emit b) ++ ["\tadd c"]}
+      o {oCode = (emit a).oCode ++ ["\tld c, a"] ++ (emit b).oCode ++ ["\tadd c"]}
     (A.BinOp A.Minus _ a (A.Num 1 _)) ->
-      o {oCode = oCode (emit a) ++ ["\tdec a"]}
+      o {oCode = (emit a).oCode ++ ["\tdec a"]}
     (A.BinOp A.Minus _ a (A.Num v _)) ->
-      o {oCode = oCode (emit a) ++ ["\tsub #" ++ show v]}
+      o {oCode = (emit a).oCode ++ ["\tsub #" ++ show v]}
     (A.BinOp A.Minus _ a b) ->
-      o {oCode = oCode (emit a) ++ ["\tld c, a"] ++ oCode (emit b) ++ ["\tld b, a", "\tld a, c", "\tsub b"]}
+      o {oCode = (emit a).oCode ++ ["\tld c, a"] ++ (emit b).oCode ++ ["\tld b, a", "\tld a, c", "\tsub b"]}
     (A.BinOp A.Mul _ _ (A.Num 0 _)) ->
       o {oCode = ["\txor a"]}
     (A.BinOp A.Mul _ (A.Num 0 _) _) ->
       o {oCode = ["\txor a"]}
-    (A.BinOp A.Mul _ (A.Num 1 _) b) -> o {oCode = oCode (emit b)}
-    (A.BinOp A.Mul _ a (A.Num 1 _)) -> o {oCode = oCode (emit a)}
+    (A.BinOp A.Mul _ (A.Num 1 _) b) -> o {oCode = (emit b).oCode}
+    (A.BinOp A.Mul _ a (A.Num 1 _)) -> o {oCode = (emit a).oCode}
     (A.BinOp A.Mul pos a b@(A.Num _ _)) -> o {oCode = mul a b pos}
     (A.BinOp A.Mul pos a@(A.Num _ _) b) -> o {oCode = mul b a pos}
     (A.BinOp A.Mul p a b) -> o {oCode = mul8 a b p}
     (A.BinOp A.Assign _ (A.Variable id _) b) ->
-      o {oCode = oCode (emit b) ++ ["\tld (" ++ toIdent id ++ "), a"]}
+      o {oCode = (emit b).oCode ++ ["\tld (" ++ toIdent id ++ "), a"]}
     _ -> o {oCode = [";; unimplemented " ++ show x]}
   where
     o = Output [] [] [] []
@@ -127,8 +127,8 @@ emit x =
 generate :: String -> [A.Expr] -> String
 generate version ast = do
   let out = map emit ast
-  let pre = concatMap oPre out
-  let dat = [area "_DATA", area "_INITIALIZED"] ++ concatMap oData out
-  let code = [area "_CODE"] ++ concatMap oCode out ++ ["hlt0:", "\tjr hlt0"]
-  let init = [area "_INITIALIZER"] ++ concatMap oInit out ++ [area "_GSINIT", area "_GSFINAL"]
+  let pre = concatMap (\f -> f.oPre) out
+  let dat = [area "_DATA", area "_INITIALIZED"] ++ concatMap (\f -> f.oData) out
+  let code = [area "_CODE"] ++ concatMap (\f -> f.oCode) out ++ ["hlt0:", "\tjr hlt0"]
+  let init = [area "_INITIALIZER"] ++ concatMap (\f -> f.oInit) out ++ [area "_GSINIT", area "_GSFINAL"]
   unlines $ header version ++ pre ++ dat ++ code ++ init
diff --git a/src/Micro/Compiler.hs b/src/Micro/Compiler.hs
index 70ce82c..81d403d 100644
--- a/src/Micro/Compiler.hs
+++ b/src/Micro/Compiler.hs
@@ -10,7 +10,7 @@ import Control.Monad.State
 import Data.Foldable (traverse_)
 import Data.Maybe (isNothing, mapMaybe)
 import Micro.Asm.Sdcc (generate)
-import qualified Micro.Ast as A
+import Micro.Ast qualified as A
 import Micro.Env
 import Micro.Error
 import Text.Parsec (SourcePos)
@@ -42,7 +42,7 @@ foldlEither fn =
 -- the compilation to continue.
 addError :: Error -> State CompState (Maybe A.Type)
 addError e = do
-  modify $ \st -> st {stErr = e : stErr st}
+  modify $ \st -> st {stErr = e : st.stErr}
   pure Nothing
 
 -- | @typecheckCall args params@ resolves @args@ and compares it with @params@,
@@ -118,7 +118,7 @@ compileOne x = do
       -- current env
       st <- get
       -- check for undefined types
-      (ev, errs) <- return (stEnv st, verifyFuncType ident params ret pos ++ stErr st)
+      (ev, errs) <- return (st.stEnv, verifyFuncType ident params ret pos ++ st.stErr)
       -- updated with the function
       (ev, errs) <-
         return $ case addSymUniq ev (Sym ident ftype priv False pos) of
@@ -148,7 +148,7 @@ compileOne x = do
         _ -> addError $ Error NonCallable "non callable value in function call" pos
     (A.Var ident typ val priv local pos) -> do
       st <- get
-      (ev, errs) <- return $ foldlEither addSymUniq (stEnv st, stErr st) [Sym ident typ priv local pos]
+      (ev, errs) <- return $ foldlEither addSymUniq (st.stEnv, st.stErr) [Sym ident typ priv local pos]
       errs <-
         return $
           if not (definedType typ)
@@ -159,7 +159,7 @@ compileOne x = do
       typecheck (Just typ) t pos
     (A.Return value pos) -> do
       st <- get
-      case getSyml (stEnv st) "$fn$" of
+      case getSyml st.stEnv "$fn$" of
         Just Sym {symType = A.FuncType _ rtyp} -> do
           case value of
             Nothing ->
@@ -172,7 +172,7 @@ compileOne x = do
         _ -> addError $ Error UnexpectedReturn "return without function call" pos
     (A.Variable ident pos) -> do
       st <- get
-      case getSym (stEnv st) ident of
+      case getSym st.stEnv ident of
         Just Sym {symType = t} -> pure $ Just t
         Nothing -> addError $ Error Undefined ("undefined \"" ++ ident ++ "\"") pos
 
@@ -211,8 +211,8 @@ compileAll :: [A.Expr] -> State CompState (Either [Error] SymMap)
 compileAll ast = do
   traverse_ compileOne ast
   st <- get
-  let (Env sym _) = stEnv st
-  let errs = stErr st
+  let (Env sym _) = st.stEnv
+  let errs = st.stErr
   case errs of
     [] -> pure $ Right sym
     _ -> return $ Left errs
diff --git a/src/Micro/Env.hs b/src/Micro/Env.hs
index 731f19a..b788214 100644
--- a/src/Micro/Env.hs
+++ b/src/Micro/Env.hs
@@ -1,8 +1,8 @@
 module Micro.Env where
 
-import qualified Data.Map as Map
+import Data.Map qualified as Map
 import Data.Maybe (isJust)
-import qualified Micro.Ast as A
+import Micro.Ast qualified as A
 import Micro.Error
 import Text.Parsec (SourcePos)
 
@@ -56,9 +56,9 @@ existsSyml env sym = isJust $ getSyml env sym
 -- environment. It will create a new enviroment if the symbol already exists
 -- (shadowing).
 addSym :: Env -> Sym -> Env
-addSym env@(Env m parent) sym = case getSym env (symId sym) of
-  Nothing -> Env (Map.insert (symId sym) sym m) parent
-  Just _ -> Env (Map.singleton (symId sym) sym) $ Just env
+addSym env@(Env m parent) sym = case getSym env sym.symId of
+  Nothing -> Env (Map.insert sym.symId sym m) parent
+  Just _ -> Env (Map.singleton sym.symId sym) $ Just env
 
 -- | @addEnv e@ adds a new local environment using @e@ as parent.
 addEnv :: Env -> Env
@@ -67,6 +67,6 @@ addEnv env = Env Map.empty $ Just env
 -- | @addSymUniq e s@ adds a local symbol @s@ to the enviroment @e@ if it
 -- doesn't exist.
 addSymUniq :: Env -> Sym -> Either Error Env
-addSymUniq ev sym = case getSyml ev (symId sym) of
+addSymUniq ev sym = case getSyml ev sym.symId of
   Nothing -> Right $ addSym ev sym
-  Just other -> Left $ Error AlreadyDefined ("\"" ++ symId sym ++ "\" already defined in " ++ show (symPos other)) $ symPos sym
+  Just other -> Left $ Error AlreadyDefined ("\"" ++ sym.symId ++ "\" already defined in " ++ show other.symPos) sym.symPos
diff --git a/src/Micro/Parser.hs b/src/Micro/Parser.hs
index 48e1900..6b6fafb 100644
--- a/src/Micro/Parser.hs
+++ b/src/Micro/Parser.hs
@@ -10,19 +10,17 @@ import Data.Maybe (isJust)
 import Micro.Ast
 import Micro.Lexer
 import Text.Parsec
-import qualified Text.Parsec.Expr as E
+import Text.Parsec.Expr qualified as E
 import Text.Parsec.String (Parser)
 
 binary :: String -> Op -> E.Assoc -> E.Operator String () Identity Expr
-binary s f assoc =
+binary s f =
   E.Infix
     ( reservedOp s
         >> do
           -- FIXME: this is the second operand
-          pos <- getPosition
-          return $ BinOp f pos
+          BinOp f <$> getPosition
     )
-    assoc
 
 opTable :: [[E.Operator String () Identity Expr]]
 opTable =