From c7cc8467ca1835c8f96ccb5be7c976a26d262433 Mon Sep 17 00:00:00 2001 From: "Juan J. Martinez" Date: Wed, 20 Dec 2023 19:53:05 +0000 Subject: Updated to use GHC 9.4.x and floating dependencies --- cabal.project | 3 +++ micro.cabal | 35 ++++++++++++++++++++--------------- src/Micro/Asm/Sdcc.hs | 44 ++++++++++++++++++++++---------------------- src/Micro/Compiler.hs | 16 ++++++++-------- src/Micro/Env.hs | 14 +++++++------- src/Micro/Parser.hs | 8 +++----- 6 files changed, 63 insertions(+), 57 deletions(-) create mode 100644 cabal.project 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 = -- cgit v1.2.3