Attempt to clean up phase 2

src/Mima/Asm/Phase1.hs

@@ -2,9 +2,9 @@
 {-# 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 <name>
 -}
 
-class Onion o where
-  peel :: o a -> a
-
 {- Types -}
 
 data Name a = Name a T.Text

src/Mima/Asm/Phase2.hs

@@ -1,20 +1,26 @@
 {-# 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
+-- | The name of a label or a meta tag.
-  = LocationNoRelAddress a Vm.MimaAddress
+data Name s = Name s T.Text
-  | LocationNoRelLabel (P1.Name a)
+  deriving (Show, Functor)
-  deriving (Show)
 
+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 'S1 s = Location1 s
-type instance LocationX 'S2 s = LocationNoRel s
+type instance LocationX 'S2 s = Location2 s
-type instance LocationX 'S3 s = LocationNoRel 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 'S1 s = Name s
-type instance TokenLabelX 'S2 s = P1.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)
+  = MetaStart s (Name s) (JsonValue s)
-  | MetaStop  (P1.Name s)
+  | MetaStop  s (Name s)
-  deriving (Show)
+  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)
+  = SmallInstruction Vm.SmallOpcode (LocationX t s)
-  | LargeInstruction (P1.LargeOpcode s) (Maybe (P1.SmallValue 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)
+  = RegIar s (LocationX t s)
-  | RegAcc s s (MimaWord t s)
+  | RegAcc s (MimaWord t s)
-  | RegRa  s s (LocationX t s)
+  | RegRa  s (LocationX t s)
-  | RegSp  s s (LocationX t s)
+  | RegSp  s (LocationX t s)
-  | RegFp  s 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) ->
+  for_ (reverse metas) $ \(MetaS1 s _ name value) ->
-    s1AddToken $ TokenMeta () $ MetaStart name value
+    s1AddToken $ TokenMeta () $
+    MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value)
   f
-  for_ metas $ \(MetaS1 _ _ name _) ->
+  for_ metas $ \(MetaS1 s _ name _) ->
-    s1AddToken $ TokenMeta () $ MetaStop 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)) =
+s1AddP1Token (P1.TokenDirective (P1.MetaStart s _ name value)) =
-  s1AddToken $ TokenMeta () $ MetaStart name value
+  s1AddToken $ TokenMeta () $
-s1AddP1Token (P1.TokenDirective (P1.MetaStop _ _ name)) =
+  MetaStart s (p1ToP2Name name) (p1ToP2JsonValue value)
-  s1AddToken $ TokenMeta () $ MetaStop name
+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

src/Mima/Asm/Types.hs

@@ -0,0 +1,6 @@
+module Mima.Asm.Types
+  ( Onion(..)
+  ) where
+
+class Onion o where
+  peel :: o a -> a