{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE GeneralizedNewtypeDeriving #-}{-# LANGUAGE NamedFieldPuns #-}{-# LANGUAGE PackageImports #-}{-# LANGUAGE TypeSynonymInstances #-}{-# OPTIONS_GHC -Wall #-}{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}-- | An implementation of Lawrence S. Moss' @1\#@ language and Text-- Register Machine (<http://www.indiana.edu/~iulg/trm/>). ---- This module also includes a slightly higher-level language, @1\#L@,-- that replaces the forward and backward relative jumps of @1\#@ with-- labels and goto instructions.moduleLanguage.TRM.Base(-- * Basic Text Register Machine-- ** Letters and WordsLetter(..),Word(..),wordToString-- ** Registers, Instructions, and Programs,Register(..),Instruction(..),instructionToString,Program,programToString,parseProgram-- ** Machine Implementation,Machine(..),step,run,phi-- * Labels and Gotos-- ** Language Definition,Label,LInstruction(..),LProgram-- ** Conversion Between Languages,toLabeledProgram,fromLabeledProgram-- ** Concrete Syntax and Semantics,LSymantics(..),LComp(..),compileL,runL,runL'-- ** Useful helpers,do_,freshLabelHere-- * Examples-- * Backwards-Binary Notation,encodeBB,decodeBB)whereimportControl.ApplicativeimportControl.Monadimport"mtl"Control.Monad.Stateimport"mtl"Control.Monad.WriterimportData.Char(isSpace)importData.Listhiding((++),break)importData.MaybeimportData.Monoid()importData.Map(Map)importqualifiedData.MapasMapimportData.Set(Set)importqualifiedData.SetasSetimportData.Vector(Vector)importqualifiedData.VectorasVectorimportGHC.Extshiding(Word)importPreludehiding((++),break,compare)importText.Printf(++)::Monoida=>a->a->a(++)=mappend---------------------------------------------------------------------------------- Basic 1# parser and machine-- | Typed representation of the @1#@ letters.dataLetter=One|Hashderiving(Eq)-- | A wrapper around a list of 'Letter's with an 'IsString' instance,-- so that literal strings of @1@s, @#@s, and whitespace can be used-- instead of lists of 'One's and 'Hash'es. This requires the-- @-XOverloadedStrings@ flag.---- > loop :: Word-- > loop = "1### 11####"newtypeWord=W[Letter]deriving(Eq,Monoid)instanceIsStringWordwherefromString[]=W[]fromString(x:xs)=let(Wls)=fromStringxsincasexof'1'->W(One:ls)'#'->W(Hash:ls)c|isSpacec->Wls_->error$"invalid 1# string: "++(x:xs)-- | Convert a 'Word' back into a 'String'.wordToString::Word->StringwordToString(W[])=""wordToString(W(One:ls))='1':wordToString(Wls)wordToString(W(Hash:ls))='#':wordToString(Wls)instanceShowWordwhereshow=show.wordToString-- | Register identifiers.newtypeRegister=RIntderiving(Eq,Ord,Show,Enum,Real,Integral,Num)-- | Abstract syntax for the primitive @1#@ instructions.dataInstruction=SnocOneRegister|SnocHashRegister|ForwardInt|BackwardInt|CaseRegisterderiving(Eq,Show)-- | Convert an 'Instruction' to concrete syntax.instructionToString::Instruction->StringinstructionToString(SnocOne(Rr))=replicater'1'++"#"instructionToString(SnocHash(Rr))=replicater'1'++"##"instructionToString(Forwardi)=replicatei'1'++"###"instructionToString(Backwardi)=replicatei'1'++"####"instructionToString(Case(Rr))=replicater'1'++"#####"-- | A @1#@ program is a 'Vector' of 'Instruction's.typeProgram=VectorInstruction-- | Convert a 'Program' to concrete syntax.programToString::Program->StringprogramToString=(intercalate" ").(mapinstructionToString).Vector.toListparseInstruction::StateTWordMaybeInstructionparseInstruction=do(Wls)<-getguard$not(nullls)let(ones,ls')=span(One==)ls(hashes,ls'')=span(Hash==)ls'put(Wls'')case(lengthones,lengthhashes)of(r,1)->return$SnocOne(Rr)(r,2)->return$SnocHash(Rr)(i,3)->return$Forwardi(i,4)->return$Backwardi(r,5)->return$Case(Rr)_->mzero-- | Parse a 'Word' into a 'Program'; returns 'Nothing' if an invalid-- instruction is found.parseProgram::Word->MaybeProgramparseProgramw=Vector.fromList<$>evalStateTloopwwhereloop=do(Wls)<-getcaselsof[]->return[]_->(:)<$>parseInstruction<*>loop-- | A 'Machine' consists of a 'Program', a program counter, and a-- 'Map' from registers to the words they contain.dataMachine=M{program::Program,pc::Int,regs::MapRegisterWord}deriving(Eq,Show)snocReg::Register->Letter->MapRegisterWord->MapRegisterWordsnocRegrlregs=Map.insertWith(flip(++))r(W[l])regsunsnocReg::Register->MapRegisterWord->Maybe(Letter,MapRegisterWord)unsnocRegrregs=caseMap.lookuprregsofNothing->mzeroJust(W[])->mzeroJust(W(One:ls))->Just(One,Map.insertr(Wls)regs)Just(W(Hash:ls))->Just(Hash,Map.insertr(Wls)regs)-- | Performs the single 'Instruction' indicated by the program-- counter, if available. Returns 'Left mach' if a step cannot be-- performed, and 'Right mach' with an updated 'Machine' otherwise.step::Machine->EitherMachineMachinestepmach@M{program,pc}|pc<0||pc>=Vector.lengthprogram=Leftmachstepmach@M{program,pc,regs}=caseprogramVector.!pcofSnocOner->return$mach{pc=pc+1,regs=snocRegrOneregs}SnocHashr->return$mach{pc=pc+1,regs=snocRegrHashregs}Forwardi->return$mach{pc=pc+i}Backwardi->return$mach{pc=pc-i}Caser->caseunsnocRegrregsofNothing->return$mach{pc=pc+1}Just(One,regs')->return$mach{pc=pc+2,regs=regs'}Just(Hash,regs')->return$mach{pc=pc+3,regs=regs'}-- | Given a 'Program' and the initial state of the registers, return-- the final state of the registers.run::Program->MapRegisterWord->MapRegisterWordrunprs=regs$finalwhereLeftfinal=loopM{program=p,pc=0,regs=rs}loopmach=stepmach>>=loopcheckState::MapRegisterWord->Maybe()checkStateregs=do_<-Map.lookup1regsletregs'=Map.delete1regsguard$all(W[]==)(Map.elemsregs')-- | Wrapper around 'run' that parses the given 'Word' into a-- 'Program', and then runs it in the given register state. Returns-- the value in register 1 once the program halts.---- Returns 'Nothing' when either the given 'Word' fails to parse, or-- if the machine halts abnormally with an invalid program counter or-- values in registers other than register 1.phi::Word->[(Register,Word)]->MaybeWordphiprs=dop'<-parseProgrampletfinal=runp'$Map.fromListrscheckStatefinalMap.lookup1$!final---------------------------------------------------------------------------------- 1#L: Labels and Gotos instead of Forward and Backward-- | Label representation.typeLabel=Int-- | Abstract syntax for a variant of @1\#@, @1\#L@ with labels and-- gotos instead of forward and backward jumps.dataLInstruction=LSnocOneRegister|LSnocHashRegister|LCaseRegister|LGotoLabel|LLabelLabelderiving(Eq,Show)-- | A @1\#L@ program is a 'Vector' of 'LInstruction's.typeLProgram=VectorLInstructionexposeLabels::Program->MapIntLabelexposeLabelsp=Vector.ifoldl'exposeLabelMap.emptypwhereend=Vector.lengthpfreshlabs=Map.sizelabsexposeLabel::MapIntLabel->Int->Instruction->MapIntLabelexposeLabellabspos(Forwardrel)|pos+rel<=end&&pos+rel>=0=Map.insertWith(\_lab->lab)(pos+rel)(freshlabs)labsexposeLabellabspos(Backwardrel)|pos-rel<=end&&pos-rel>=0=Map.insertWith(\_lab->lab)(pos-rel)(freshlabs)labsexposeLabel__(Forward_)=error"forward jump out of range"exposeLabel__(Backward_)=error"backward jump out of range"exposeLabellabs__=labs-- | Convert a @1\#@ 'Program' into a semantically-equivalent @1\#L@-- 'LProgram'. May fail with an error if the original 'Program' is-- /non-tidy/, that is it contains forward or backward jumps to-- instructions outside of the program.toLabeledProgram::Program->LProgramtoLabeledProgramp=Vector.concat(insertLabels0)wherelabels=exposeLabelspp'=Vector.imapsubstLabelpsubstLabel_(SnocOner)=LSnocOnersubstLabel_(SnocHashr)=LSnocHashrsubstLabel_(Caser)=LCasersubstLabelpos(Forwardrel)=caseMap.lookup(pos+rel)labelsofJustlab->LGotolabNothing->error"couldn't find label for position"substLabelpos(Backwardrel)=caseMap.lookup(pos-rel)labelsofJustlab->LGotolabNothing->error"couldn't find label for position"insertLabelsi|i==Vector.lengthp'=caseMap.lookupilabelsofNothing->[]Justlab->[Vector.singleton$LLabellab]insertLabelsi=caseMap.lookupilabelsofNothing->(Vector.singleton$p'Vector.!i):insertLabels(i+1)Justlab->(Vector.fromList$[LLabellab,p'Vector.!i]):insertLabels(i+1)exposePositions::LProgram->MapLabelIntexposePositionslp=fst$Vector.ifoldl'exposePosition(Map.empty,0)lpwhereexposePosition(poss,seen)pos(LLabellab)=(Map.insertWith(error$"duplicate label "++showlab)lab(pos-seen)poss,seen+1)exposePositionp__=p-- | Convert a @1\#L@ 'LProgram' into a semantically-equivalent @1\#@-- 'Program'. May fail with an error if the 'LProgram' contains-- duplicate labels, jumps to undefined labels. An error will also-- occur if the 'LProgram' contains a goto that would translate into a-- jump of 0 instructions, as this is impossible to express in @1\#@.fromLabeledProgram::LProgram->ProgramfromLabeledProgramlp=insertJumps.removeLabels$lpwhereremoveLabels=Vector.filter(not.isLabel)isLabel(LLabel_)=TrueisLabel_=Falseposs=exposePositionslpinsertJumps=Vector.imapinsertJumpinsertJump_(LSnocOner)=SnocOnerinsertJump_(LSnocHashr)=SnocHashrinsertJump_(LCaser)=CaserinsertJumppos(LGotolab)=caseMap.lookuplabpossofNothing->error$"unbound label "++showlabJustdest|dest>pos->Forward(dest-pos)|dest<pos->Backward(pos-dest)|otherwise->error"can't jump to self"insertJump_(LLabel_)=error"labels shouldn't exist here"-- | Concrete syntax for @1\#L@, indexed by backend representation in-- the typed tagless style-- (<http://okmij.org/ftp/tagless-final/index.html>).classLSymanticsreprwhere-- | Append a @1@ to the end of the given 'Register'.snocOne::Register->repr()-- | Append a @#@ to the end of the given 'Register'.snocHash::Register->repr()-- | Return a fresh 'Label' to be used in a call to 'label' or 'goto'.freshLabel::reprLabel-- | Place a 'Label' at the given point in the program. Note that a-- particular 'Label' may be used only once per program.label::Label->repr()-- | Unconditional jump to the given 'Label'.goto::Label->repr()-- | Case analysis; pops a 'Letter' from the front of the-- scrutinized 'Register', if non-empty. Note that in the default-- backend, new labels are automatically created and placed for the-- branches of the 'cond'.cond::Register-- ^ The 'Register' to scrutinize.->repr()-- ^ Run if the 'Register' is empty.->repr()-- ^ Run if the front of the 'Register' is a @1@.->repr()-- ^ Run if the front of the 'Register' is a @#@.->repr()-- | The default backend for 'LSymantics'.newtypeLCompa=LC{unLC::StateT(Int,SetLabel)(WriterLProgram)a}deriving(Functor,Applicative,Monad,MonadFix,MonadState(Int,SetLabel),MonadWriterLProgram)instanceLSymanticsLCompwheresnocOne=tell.Vector.singleton.LSnocOnesnocHash=tell.Vector.singleton.LSnocHashfreshLabel=do(l,ls)<-getput(l+1,ls)returnllabell=do(l',ls)<-getcaseSet.memberllsofTrue->error$printf"duplicate label %s"lFalse->doput(l',Set.insertlls)tell.Vector.singleton$LLabellgoto=tell.Vector.singleton.LGotocondrbEmptybOnebHash=do[lEmpty,lOne,lHash]<-replicateM3freshLabeltell.Vector.singleton$LCasergotolEmpty>>gotolOne>>gotolHashlabellEmpty>>bEmptylabellOne>>bOnelabellHash>>bHash-- | Convenience function to create a fresh label and place it at the-- current position.freshLabelHere::(Monadrepr,LSymanticsrepr)=>reprLabelfreshLabelHere=dol<-freshLabel;labell;returnl-- | Compiles an 'LComp' program into an 'LProgram'.compileL::LComp()->LProgramcompileLprog=execWriter(evalStateT(unLCprog)(0,Set.empty))-- | Given an 'LComp' program and an initial register state, and then-- runs it in the given register state. May return 'Nothing' if the-- program does not halt cleanly, as with 'run'.runL::LComp()->[(Register,Word)]->MaybeWordrunLprs=doletfinal=(run.fromLabeledProgram.compileL$p)(Map.fromListrs)checkStatefinalMap.lookup1final-- | Given an 'LComp' program and an initial register state, and then-- runs it in the given register state. May return 'Nothing' if the-- program does not halt cleanly, as with 'run'.runL'::LComp()->[(Register,Word)]->[(Register,Word)]runL'prs=Map.toListfinalwherefinal=(run.fromLabeledProgram.compileL$p)(Map.fromListrs)---------------------------------------------------------------------------------- Backwards binary encoding-- | Encodes an 'Integral' type into a 'Word' of backwards-binary-- digits using @1@s and @#@s for @1@s and @0@s, respectively. Note-- that the representation of zero is a single @#@ rather than the-- empty 'Word'.encodeBB::Integrala=>a->WordencodeBBx|toIntegerx==0=W[Hash]|otherwise=W(enc(toIntegerx))whereenc0=[]encn|oddn=One:(enc$n`div`2)|evenn=Hash:(enc$n`div`2)enc_=error"encodeBB only accepts non-negative integers"-- | Decodes a 'Word' containing backwards-binary digits into a 'Num'-- type. Fails with an error if the 'Word' is empty.decodeBB::Numa=>Word->adecodeBB(W[])=error"Backwards-binary words cannot be empty"decodeBB(Wys)=fromInteger$decyswheredec[]=0dec(Hash:xs)=2*decxsdec(One:xs)=1+(2*decxs)-- | A combinator to cleanly implement looping structures in 'LComp' code.-- -- Takes a function that expects two arguments, @continue@ and-- @break@. The body of the function is a block of 'LComp' code that-- gets repeated whenever @continue@ is run. If @break@ is run,-- control jumps to the instruction after the call to 'do_'.do_::(LComp()->LComp()->LComp())->LComp()do_f=dobreak<-freshLabelcontinue<-freshLabelHeref(gotocontinue)(gotobreak)labelbreak