From 96c28c1f31e7ed46cf6fcdd0d9682d722e5e9344 Mon Sep 17 00:00:00 2001 From: Joscha Date: Fri, 3 Apr 2020 16:59:26 +0000 Subject: [PATCH] Attempt to clean up phase 2 --- src/Mima/Asm/Phase1.hs | 10 +- src/Mima/Asm/Phase2.hs | 219 ++++++++++++++++++++++++++++++----------- src/Mima/Asm/Types.hs | 6 ++ 3 files changed, 172 insertions(+), 63 deletions(-) create mode 100644 src/Mima/Asm/Types.hs diff --git a/src/Mima/Asm/Phase1.hs b/src/Mima/Asm/Phase1.hs index 0fd13ac..381d4f6 100644 --- a/src/Mima/Asm/Phase1.hs +++ b/src/Mima/Asm/Phase1.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE OverloadedStrings #-} module Mima.Asm.Phase1 - ( Onion(..) + ( -- * Types - , Name(..) + Name(..) , Address(..) , Location(..) , SmallOpcode(..) @@ -38,6 +38,7 @@ import Text.Megaparsec import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer hiding (space) +import Mima.Asm.Types import Mima.Format import qualified Mima.Vm.Instruction as Vm import qualified Mima.Vm.Word as Vm @@ -61,9 +62,6 @@ import qualified Mima.Vm.Word as Vm .meta-stop -} -class Onion o where - peel :: o a -> a - {- Types -} data Name a = Name a T.Text diff --git a/src/Mima/Asm/Phase2.hs b/src/Mima/Asm/Phase2.hs index ace0bde..b74cc5e 100644 --- a/src/Mima/Asm/Phase2.hs +++ b/src/Mima/Asm/Phase2.hs @@ -1,20 +1,26 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} module Mima.Asm.Phase2 - ( phaseS1 + ( phaseS1 -- TODO only leave the proper types ) where import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.State +import qualified Data.Aeson as A import Data.Foldable import qualified Data.Map.Strict as Map import qualified Data.Text as T import Data.Void import qualified Mima.Asm.Phase1 as P1 +import Mima.Asm.Types import Mima.Asm.Weed +import qualified Mima.Vm.Instruction as Vm import qualified Mima.Vm.Word as Vm data Subphase @@ -33,18 +39,44 @@ data Subphase | S5 -- ^ After extracting all initial register values. -data LocationNoRel a - = LocationNoRelAddress a Vm.MimaAddress - | LocationNoRelLabel (P1.Name a) - deriving (Show) +-- | The name of a label or a meta tag. +data Name s = Name s T.Text + deriving (Show, Functor) +instance Onion Name where + peel (Name s _) = s + +-- | A location defined by an absolute or relative address or by a label. +data Location1 s + = Loc1Absolute s Vm.MimaAddress + | Loc1Relative s Integer + | Loc1Label (Name s) + deriving (Show, Functor) + +instance Onion Location1 where + peel (Loc1Absolute s _) = s + peel (Loc1Relative s _) = s + peel (Loc1Label l) = peel l + +-- | A location defined by an absolute address or by a label. +data Location2 s + = Loc2Absolute s Vm.MimaAddress + | Loc2Label (Name s) + deriving (Show, Functor) + +instance Onion Location2 where + peel (Loc2Absolute s _) = s + peel (Loc2Label l) = peel l + +-- | A type family for locations in various stages of resolution. type family LocationX (t :: Subphase) (s :: *) -type instance LocationX 'S1 s = P1.Location s -type instance LocationX 'S2 s = LocationNoRel s -type instance LocationX 'S3 s = LocationNoRel s +type instance LocationX 'S1 s = Location1 s +type instance LocationX 'S2 s = Location2 s +type instance LocationX 'S3 s = Location2 s type instance LocationX 'S4 s = Vm.MimaAddress type instance LocationX 'S5 s = Vm.MimaAddress +-- | A type family for addresses of various tokens. type family AddressX (t :: Subphase) (s :: *) type instance AddressX 'S1 s = () type instance AddressX 'S2 s = Vm.MimaAddress @@ -52,24 +84,46 @@ type instance AddressX 'S3 s = Vm.MimaAddress type instance AddressX 'S4 s = Vm.MimaAddress type instance AddressX 'S5 s = Vm.MimaAddress +-- | A representation for .org addresses. +data OrgAddress s + = OrgAddrAbsolute s Vm.MimaAddress + | OrgAddrRelative s Integer + deriving (Show, Functor) + +instance Onion OrgAddress where + peel (OrgAddrAbsolute s _) = s + peel (OrgAddrRelative s _) = s + type family TokenOrgX (t :: Subphase) (s :: *) -type instance TokenOrgX 'S1 s = P1.Address s +type instance TokenOrgX 'S1 s = OrgAddress s type instance TokenOrgX 'S2 s = Void type instance TokenOrgX 'S3 s = Void type instance TokenOrgX 'S4 s = Void type instance TokenOrgX 'S5 s = Void type family TokenLabelX (t :: Subphase) (s :: *) -type instance TokenLabelX 'S1 s = P1.Name s -type instance TokenLabelX 'S2 s = P1.Name s +type instance TokenLabelX 'S1 s = Name s +type instance TokenLabelX 'S2 s = Name s type instance TokenLabelX 'S3 s = Void type instance TokenLabelX 'S4 s = Void type instance TokenLabelX 'S5 s = Void +-- | A wrapper that annotates a 'A.Value' with an @s@ value. +data JsonValue s = JsonValue s A.Value + deriving (Show, Functor) + +instance Onion JsonValue where + peel (JsonValue s _) = s + +-- | A representation for .meta-start and .meta-stop directives. data Meta s - = MetaStart (P1.Name s) (P1.JsonValue s) - | MetaStop (P1.Name s) - deriving (Show) + = MetaStart s (Name s) (JsonValue s) + | MetaStop s (Name s) + deriving (Show, Functor) + +instance Onion Meta where + peel (MetaStart s _ _) = s + peel (MetaStop s _) = s type family TokenMetaX (t :: Subphase) (s :: *) type instance TokenMetaX 'S1 s = Meta s @@ -78,27 +132,49 @@ type instance TokenMetaX 'S3 s = Void type instance TokenMetaX 'S4 s = Void type instance TokenMetaX 'S5 s = Void +-- | A stripped-down representation of Mima words that does not have an 'Onion' +-- instance because none is required. data MimaWord (t :: Subphase) (s :: *) - = WordRaw s Vm.MimaWord + = WordRaw Vm.MimaWord | WordLocation (LocationX t s) +deriving instance Show s => Show (MimaWord 'S1 s) +deriving instance Show s => Show (MimaWord 'S2 s) +deriving instance Show s => Show (MimaWord 'S3 s) +deriving instance Show s => Show (MimaWord 'S4 s) +deriving instance Show s => Show (MimaWord 'S5 s) + +-- | A stripped-down representation of Mima instructions that does not have an +-- 'Onion' instance because none is required. data Instruction (t :: Subphase) (s :: *) - = SmallInstruction (P1.SmallOpcode s) (LocationX t s) - | LargeInstruction (P1.LargeOpcode s) (Maybe (P1.SmallValue s)) + = SmallInstruction Vm.SmallOpcode (LocationX t s) + | LargeInstruction Vm.LargeOpcode (Maybe Vm.SmallValue) + +deriving instance Show s => Show (Instruction 'S1 s) +deriving instance Show s => Show (Instruction 'S2 s) +deriving instance Show s => Show (Instruction 'S3 s) +deriving instance Show s => Show (Instruction 'S4 s) +deriving instance Show s => Show (Instruction 'S5 s) type family TokenInstrX (t :: Subphase) (s :: *) type instance TokenInstrX 'S1 s = Instruction 'S1 s type instance TokenInstrX 'S2 s = Instruction 'S2 s type instance TokenInstrX 'S3 s = Instruction 'S3 s -type instance TokenInstrX 'S4 s = Instruction 'S4 s +type instance TokenInstrX 'S4 s = Void type instance TokenInstrX 'S5 s = Void data RegisterDirective (t :: Subphase) (s :: *) - = RegIar s s (LocationX t s) - | RegAcc s s (MimaWord t s) - | RegRa s s (LocationX t s) - | RegSp s s (LocationX t s) - | RegFp s s (LocationX t s) + = RegIar s (LocationX t s) + | RegAcc s (MimaWord t s) + | RegRa s (LocationX t s) + | RegSp s (LocationX t s) + | RegFp s (LocationX t s) + +deriving instance Show s => Show (RegisterDirective 'S1 s) +deriving instance Show s => Show (RegisterDirective 'S2 s) +deriving instance Show s => Show (RegisterDirective 'S3 s) +deriving instance Show s => Show (RegisterDirective 'S4 s) +deriving instance Show s => Show (RegisterDirective 'S5 s) type family TokenRegX (t :: Subphase) (s :: *) type instance TokenRegX 'S1 s = RegisterDirective 'S1 s @@ -115,20 +191,60 @@ data AsmToken (t :: Subphase) (s :: *) | TokenInstr (AddressX t s) (TokenInstrX t s) | TokenReg (AddressX t s) (TokenRegX t s) +deriving instance Show s => Show (AsmToken 'S1 s) +deriving instance Show s => Show (AsmToken 'S2 s) +deriving instance Show s => Show (AsmToken 'S3 s) +deriving instance Show s => Show (AsmToken 'S4 s) +deriving instance Show s => Show (AsmToken 'S5 s) + type Phase2 t s = [AsmToken t s] {- Subphase 1 -} +p1ToP2Name :: P1.Name s -> Name s +p1ToP2Name (P1.Name s text) = Name s text + +p1ToP2JsonValue :: P1.JsonValue s -> JsonValue s +p1ToP2JsonValue (P1.JsonValue s value) = JsonValue s value + +p1ToP2Address :: P1.Address s -> OrgAddress s +p1ToP2Address (P1.AddressAbsolute s addr) = OrgAddrAbsolute s addr +p1ToP2Address (P1.AddressRelative s offset) = OrgAddrRelative s offset + +p1ToP2Location :: P1.Location s -> Location1 s +p1ToP2Location (P1.LocationAddress (P1.AddressAbsolute s addr)) = + Loc1Absolute s addr +p1ToP2Location (P1.LocationAddress (P1.AddressRelative s offset)) = + Loc1Relative s offset +p1ToP2Location (P1.LocationLabel name) = Loc1Label $ p1ToP2Name name + +p1ToP2Instruction :: P1.Instruction s -> Instruction 'S1 s +p1ToP2Instruction (P1.SmallInstruction _ (P1.SmallOpcode _ so) loc) = + SmallInstruction so $ p1ToP2Location loc +p1ToP2Instruction (P1.LargeInstruction _ (P1.LargeOpcode _ lo) maybeSv) = + LargeInstruction lo $ fmap (\(P1.SmallValue _ sv) -> sv) maybeSv + +p1ToP2Word :: P1.MimaWord s -> MimaWord 'S1 s +p1ToP2Word (P1.WordRaw _ w) = WordRaw w +p1ToP2Word (P1.WordLocation loc) = WordLocation $ p1ToP2Location loc + +p1ToP2RegDir :: P1.RegisterDirective s -> RegisterDirective 'S1 s +p1ToP2RegDir (P1.RegIar s _ loc) = RegIar s $ p1ToP2Location loc +p1ToP2RegDir (P1.RegAcc s _ word) = RegAcc s $ p1ToP2Word word +p1ToP2RegDir (P1.RegRa s _ loc) = RegRa s $ p1ToP2Location loc +p1ToP2RegDir (P1.RegSp s _ loc) = RegSp s $ p1ToP2Location loc +p1ToP2RegDir (P1.RegFp s _ loc) = RegFp s $ p1ToP2Location loc + data MetaS1 s = MetaS1 s s (P1.Name s) (P1.JsonValue s) deriving (Show) -instance P1.Onion MetaS1 where +instance Onion MetaS1 where peel (MetaS1 s _ _ _) = s data StateS1 s = StateS1 { s1Metas :: Map.Map T.Text (MetaS1 s) , s1Tokens :: [AsmToken 'S1 s] - } + } deriving (Show) type WeedS1 s = StateT (StateS1 s) (Weed (WeedError s)) @@ -149,48 +265,37 @@ s1TakeMetas = do s1WithMetas :: WeedS1 s () -> WeedS1 s () s1WithMetas f = do metas <- s1TakeMetas - for_ (reverse metas) $ \(MetaS1 _ _ name value) -> - s1AddToken $ TokenMeta () $ MetaStart name value + for_ (reverse metas) $ \(MetaS1 s _ name value) -> + s1AddToken $ TokenMeta () $ + MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value) f - for_ metas $ \(MetaS1 _ _ name _) -> - s1AddToken $ TokenMeta () $ MetaStop name + for_ metas $ \(MetaS1 s _ name _) -> + s1AddToken $ TokenMeta () $ + MetaStop s (p1ToP2Name name) s1AddToken :: AsmToken 'S1 s -> WeedS1 s () s1AddToken t = modify $ \s -> s{s1Tokens = t : s1Tokens s} -p1InstrToP2Instr :: P1.Instruction s -> Instruction 'S1 s -p1InstrToP2Instr (P1.SmallInstruction _ so loc) = SmallInstruction so loc -p1InstrToP2Instr (P1.LargeInstruction _ lo sv) = LargeInstruction lo sv - -p1WordToP2Word :: P1.MimaWord s -> MimaWord 'S1 s -p1WordToP2Word (P1.WordRaw s w) = WordRaw s w -p1WordToP2Word (P1.WordLocation loc) = WordLocation loc - -p1RegDirToP2RegDir :: P1.RegisterDirective s -> RegisterDirective 'S1 s -p1RegDirToP2RegDir (P1.RegIar s1 s2 loc) = RegIar s1 s2 loc -p1RegDirToP2RegDir (P1.RegAcc s1 s2 word) = RegAcc s1 s2 $ p1WordToP2Word word -p1RegDirToP2RegDir (P1.RegRa s1 s2 loc) = RegRa s1 s2 loc -p1RegDirToP2RegDir (P1.RegSp s1 s2 loc) = RegSp s1 s2 loc -p1RegDirToP2RegDir (P1.RegFp s1 s2 loc) = RegFp s1 s2 loc - s1AddP1Token :: P1.AsmToken s -> WeedS1 s () -s1AddP1Token (P1.TokenLabel name) = s1AddToken $ TokenLabel () name +s1AddP1Token (P1.TokenLabel name) = + s1AddToken $ TokenLabel () $ p1ToP2Name name s1AddP1Token (P1.TokenInstruction instr) = - s1AddToken $ TokenInstr () $ p1InstrToP2Instr instr + s1AddToken $ TokenInstr () $ p1ToP2Instruction instr s1AddP1Token (P1.TokenDirective (P1.Reg _ _ regDir)) = - s1AddToken $ TokenReg () $ p1RegDirToP2RegDir regDir + s1AddToken $ TokenReg () $ p1ToP2RegDir regDir s1AddP1Token (P1.TokenDirective (P1.Org _ _ addr)) = - s1AddToken $ TokenOrg addr + s1AddToken $ TokenOrg $ p1ToP2Address addr s1AddP1Token (P1.TokenDirective (P1.Lit _ _ w)) = - s1WithMetas $ s1AddToken $ TokenLit () $ p1WordToP2Word w + s1WithMetas $ s1AddToken $ TokenLit () $ p1ToP2Word w s1AddP1Token (P1.TokenDirective (P1.Arr _ _ ws)) = - s1WithMetas $ for_ ws $ s1AddToken . TokenLit () . p1WordToP2Word + s1WithMetas $ for_ ws $ s1AddToken . TokenLit () . p1ToP2Word s1AddP1Token (P1.TokenDirective (P1.Meta s1 s2 name value)) = s1AddMeta s1 s2 name value -s1AddP1Token (P1.TokenDirective (P1.MetaStart _ _ name value)) = - s1AddToken $ TokenMeta () $ MetaStart name value -s1AddP1Token (P1.TokenDirective (P1.MetaStop _ _ name)) = - s1AddToken $ TokenMeta () $ MetaStop name +s1AddP1Token (P1.TokenDirective (P1.MetaStart s _ name value)) = + s1AddToken $ TokenMeta () $ + MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value) +s1AddP1Token (P1.TokenDirective (P1.MetaStop s _ name)) = + s1AddToken $ TokenMeta () $ MetaStop s (p1ToP2Name name) s1AddP1Token P1.TokenComment{} = pure () phaseS1 :: P1.Phase1 s -> Weed (WeedError s) (Phase2 'S1 s) @@ -198,5 +303,5 @@ phaseS1 ts = do let initialS = StateS1 Map.empty [] s <- execStateT (traverse_ s1AddP1Token ts) initialS for_ (Map.elems $ s1Metas s) $ \m -> - harmless $ errorWith (P1.peel m) "unconsumed .meta" + harmless $ errorWith (peel m) "unconsumed .meta" pure $ s1Tokens s diff --git a/src/Mima/Asm/Types.hs b/src/Mima/Asm/Types.hs new file mode 100644 index 0000000..cc9425f --- /dev/null +++ b/src/Mima/Asm/Types.hs @@ -0,0 +1,6 @@ +module Mima.Asm.Types + ( Onion(..) + ) where + +class Onion o where + peel :: o a -> a