packages feed

shimmer 0.1.1 → 0.1.2

raw patch · 65 files changed

+5437/−4559 lines, 65 files

Files

+ SMR/CLI/Config.hs view
@@ -0,0 +1,77 @@++module SMR.CLI.Config where+import qualified System.Exit    as System+++-- | Command line mode.+data Mode+        -- No mode specified.+        = ModeNone++        -- Start the REPL with the given file.+        | ModeREPL  (Maybe FilePath)++        -- Load a file and print the human readable version to stdout.+        | ModeLoad FilePath++        -- Convert a file from one format to another.+        | ModeConvert FilePath FilePath+        deriving Show+++-- | Command line config.+data Config+        = Config+        { configMode    :: Mode }+        deriving Show+++configZero :: Config+configZero+        = Config+        { configMode    = ModeNone }+++-- | Parse command-line arguments.+parseArgs :: [String] -> Config -> IO Config+parseArgs [] config+ = return config++parseArgs ss config+ | "-help"  : _ssRest <- ss+ = do   putStr usage+        System.exitSuccess++ | "--help"  : _ssRest <- ss+ = do   putStr usage+        System.exitSuccess++ | "-load" : filePath : ssRest <- ss+ = parseArgs ssRest+ $ config { configMode = ModeLoad filePath }++ | "-convert" : fileSource : fileDest : ssRest <- ss+ = parseArgs ssRest+ $ config { configMode = ModeConvert fileSource fileDest }++ | filePath : ssRest <- ss+ , c : _       <- filePath+ , c /= '-'+ = parseArgs ssRest+ $ config { configMode  = ModeREPL (Just filePath) }++ | otherwise+ = do   putStr usage+        System.exitSuccess++usage :: String+usage+ = unlines+ [ "Shimmer, the reflective lambda machine."+ , ""+ , "  shimmer                       Start the REPL with no source file."+ , "  shimmer FILE                  Start the REPL with the given source file."+ , "  shimmer -help                 Display this help page."+ , "  shimmer -load FILE            Load a file and print it to stdout."+ , "  shimmer -convert FILE1 FILE2  Convert file from one format to another."+ , ""]
+ SMR/CLI/Driver/Load.hs view
@@ -0,0 +1,53 @@++module SMR.CLI.Driver.Load+        (runLoadFileDecls)+where+import qualified SMR.Prim.Op                    as Prim+import qualified SMR.Prim.Name                  as Prim+import qualified SMR.Source.Parser              as Source+import qualified SMR.Source.Lexer               as Source+import qualified SMR.Core.Codec.Peek            as Codec+import SMR.Core.Exp                             (Decl)+import SMR.Prim.Op.Base                         (Prim)++import qualified Foreign.Marshal.Alloc          as Foreign++import qualified System.FilePath                as System+import qualified System.IO                      as System+import Control.Monad+import Data.Text                                (Text)+++-- | Load decls from the given file.+runLoadFileDecls :: FilePath -> IO [Decl Text Prim]+runLoadFileDecls path+ -- Shimmer text source file.+ | System.takeExtension path == ".smr"+ = do   str     <- readFile path++        let (ts, _loc, _csRest)+                = Source.lexTokens (Source.L 1 1) str++        let config+                = Source.Config+                { Source.configReadSym  = Just+                , Source.configReadPrm  = Prim.readPrim Prim.primNames }++        case Source.parseDecls config ts of+         Left err       -> error $ show err+         Right decls    -> return decls+++ -- Shimmer binary store file.+ | System.takeExtension path == ".sms"+ = do+        h     <- System.openBinaryFile path System.ReadMode+        nSize <- fmap fromIntegral $ System.hFileSize h+        Foreign.allocaBytes nSize $ \pBuf+         -> do  nRead <- System.hGetBuf h pBuf nSize+                when (nRead /= nSize) $ error "runConvert: short read"+                (decls, _p, _n) <- Codec.peekFileDecls pBuf nSize+                return decls++ | otherwise+ = error "runLoadFileDecls: cannot load this file"
+ SMR/CLI/Help.hs view
@@ -0,0 +1,58 @@++module SMR.CLI.Help where+++helpCommands :: String+helpCommands+ = unlines $+ [ "  :quit,:q        Quit the REPL."+ , "  :help           Show this Help page."+ , "  :grammar        Show the language grammar."+ , "  :prims          Show the list of available primitives."+ , "  :reload,:r      Reload the current source files."+ , "  :decls  NAMES?  Show named declarations, or all decls if no names given."+ , "  :parse  EXP     Parse an expression and print it back."+ , "  :push   EXP     Push down substitutions in an expression."+ , "  :step   EXP     Single step evaluate an expression."+ , "  :steps  EXP     Multi-step evaluate an expression."+ , "  :trace  EXP     Multi-step evaluate an expression, showing intermediate states." ]+++helpGrammar :: String+helpGrammar+ = unlines $+ [ "  Decl  ::= '@' Name Param* '=' Exp ';'    (Macro declaration)"+ , ""+ , "  Exp   ::=  Ref                           (External reference)"+ , "         |   Key Exp                       (Keyword  application)"+ , "         |   Exp Exp+                      (Function application)"+ , "         |   Name ('^' Nat)?               (Variable with lifting specifier)"+ , "         |   '\\' Param+ '.' Exp            (Function abstraction)"+ , "         |   Train      '.' Exp            (Substitution train)"+ , ""+ , "  Ref   ::= '@' Name                       (Macro reference)"+ , "         |  '%' Name                       (Symbol reference)"+ , "         |  '#' Name                       (Primitive reference)"+ , "         |  '?' Nat                        (Nominal reference)"+ , ""+ , "  Key   ::= '##tag'                        (Tag an expression)"+ , "         |  '##seq'                        (Sequence evaluation)"+ , "         |  '##box'                        (Box an expression, delaying evaluation)"+ , "         |  '##run'                        (Run an expression, forcing  evaluation)"+ , ""+ , "  Param ::= Name                           (Call-by-value parameter)"+ , "         |  '!' Name                       (Explicitly call-by-value parameter)"+ , "         |  '~' Name                       (Explicitly call-by-name  parameter)"+ , ""+ , "  Train ::= Car+                           (Substitution train)"+ , ""+ , "  Car   ::= '['  Bind,* ']'                (Simultaneous substitution)"+ , "         |  '[[' Bind,* ']]'               (Recursive substitution)"+ , "         |  '{'  Bump,* '}'                (Lifting specifier)"+ , ""+ , "  Bind  ::= Name ('^' Nat)? '=' Exp        (Variable substitution binding)"+ , "         |  '?' Nat         '=' Exp        (Nominal  substitution binding)"+ , ""+ , "  Bump  ::= Name ('^' Nat)? ':' Nat        (Lifting bump)"+ ]+
+ SMR/CLI/Repl.hs view
@@ -0,0 +1,386 @@+{-# LANGUAGE BangPatterns #-}+module SMR.CLI.Repl where+import SMR.Core.Exp+import qualified SMR.CLI.Help                   as Help+import qualified SMR.CLI.Driver.Load            as Driver+import qualified SMR.Core.Step                  as Step+import qualified SMR.Core.World                 as World+import qualified SMR.Prim.Name                  as Prim+import qualified SMR.Prim.Op                    as Prim+import qualified SMR.Prim.Op.Base               as Prim+import qualified SMR.Source.Parser              as Source+import qualified SMR.Source.Lexer               as Source+import qualified SMR.Source.Pretty              as Source+import qualified SMR.Source.Expected            as Source+import qualified Data.Text.Lazy.IO              as TL+import qualified Data.Text.Lazy.Builder         as BL+import qualified System.Console.Haskeline       as HL+import qualified Data.Char                      as Char+import qualified Data.Map                       as Map+import qualified Data.Set                       as Set+import qualified Data.Text                      as Text+import Control.Monad.IO.Class+import Data.Text                                (Text)+import Data.Set                                 (Set)+import Data.Monoid+++-------------------------------------------------------------------------------+data Mode s p w+        = ModeNone+        | ModeParse+        | ModePush (Exp s p)+        | ModeStep (Step.Config s p w) (Exp s p)+++data State s p w+        = State+        { -- | Current interpreter mode.+          stateMode     :: Mode s p w++          -- | Top-level declarations parsed from source files.+        , stateDecls    :: [Decl s p]++          -- | Working source files.+        , stateFiles    :: [FilePath]++          -- | Execution world.+        , stateWorld    :: World.World w }+++type RState     = State Text Prim.Prim ()+type RConfig    = Step.Config Text Prim.Prim ()+type RWorld     = World.World  ()+type RDecl      = Decl  Text Prim.Prim+type RExp       = Exp   Text Prim.Prim+++-------------------------------------------------------------------------------+replStart :: RState -> IO ()+replStart state+ = HL.runInputT HL.defaultSettings+ $ do   HL.outputStrLn "Shimmer, version 0.1. The Lambda Machine."+        HL.outputStrLn "Type :help for help."+        replReload state+++-- | Main repl loop dispatcher+replLoop :: RState -> HL.InputT IO ()+replLoop state+ = do   minput  <- HL.getInputLine "> "+        case minput of+         Nothing+          -> return ()++         Just input+          |  all Char.isSpace input+          -> case stateMode state of+                ModeNone        -> replLoop state+                ModePush xx     -> replPush_next state xx+                ModeStep c xx   -> replStep_next state c xx+                _               -> replLoop state++          | otherwise+          -> case words input of+                ":quit"    : []   -> replQuit    state+                ":help"    : []   -> replHelp    state+                ":reload"  : []   -> replReload  state+                ":r"       : []   -> replReload  state+                ":grammar" : []   -> replGrammar state+                ":prims"   : []   -> replPrims   state++                ":decls"   : xs+                 -> let strip ('@' : name) = name+                        strip name         = name+                    in  replDecls state+                                $ Set.fromList $ map Text.pack+                                $ map strip xs++                ":parse"   : xs   -> replParse   state (unwords xs)+                ":push"    : xs   -> replPush    state (unwords xs)+                ":step"    : xs   -> replStep    state (unwords xs)+                ":steps"   : xs   -> replSteps   state (unwords xs)+                ":trace"   : xs   -> replTrace   state (unwords xs)+                _                 -> replSteps   state input+++-------------------------------------------------------------------------------+-- | Quit the repl.+replQuit  :: RState -> HL.InputT IO ()+replQuit _state+ = do   return ()+++-------------------------------------------------------------------------------+-- | Display the help page.+replHelp  :: RState -> HL.InputT IO ()+replHelp state+ = do   HL.outputStr $ Help.helpCommands+        replLoop state+++-------------------------------------------------------------------------------+-- | Display the language grammar.+replGrammar  :: RState -> HL.InputT IO ()+replGrammar state+ = do   HL.outputStr $ Help.helpGrammar+        replLoop state+++-------------------------------------------------------------------------------+-- | Display the list of primops.+replPrims  :: RState -> HL.InputT IO ()+replPrims state+ = do   HL.outputStrLn+         $ "  name          params    description"++        HL.outputStrLn+         $ "  ----          ------    -----------"++        HL.outputStr+         $ unlines+         [ "  #unit                   unit value"+         , "  #true                   boolean true"+         , "  #false                  boolean false"+         , "  #nat'NAT                natural number"+         , "  #list                   list constructor" ]++        HL.outputStr+         $ unlines+         $ [   leftPad 16 ("  #" ++ (Text.unpack $ name))+            ++ leftPad 10  (concat [showForm f | f <- Prim.primEvalForm p])+            ++ Text.unpack (Prim.primEvalDesc p)++           | p@(Prim.PrimEval { Prim.primEvalName = Prim.PrimOp name })+                <- Prim.primOps ]++        replLoop state++showForm :: Form -> String+showForm PVal   = "!"+showForm PExp   = "~"++leftPad :: Int -> [Char] -> [Char]+leftPad n ss+ = ss ++ replicate (n - length ss) ' '+++-------------------------------------------------------------------------------+-- | Display the list of current declarations.+replDecls :: RState -> Set Name -> HL.InputT IO ()+replDecls state names+ = do   liftIO  $ mapM_ (printDecl names)+                $ stateDecls state++        replLoop state+++printDecl :: Set Name -> RDecl -> IO ()+printDecl names decl+ | Set.null names+ = do TL.putStr+         $ BL.toLazyText+         $ Source.buildDecl decl++ | DeclMac name _ <- decl+ , Set.member name names+ = do   TL.putStr+         $ BL.toLazyText+         $ Source.buildDecl decl++ | otherwise+ = return ()+++-------------------------------------------------------------------------------+-- | Reload the current source file.+replReload :: RState -> HL.InputT IO ()+replReload state+ = do+        decls   <- liftIO+                $  fmap concat $ mapM Driver.runLoadFileDecls+                $  stateFiles state++        replLoop (state+                { stateDecls    = decls })+++-------------------------------------------------------------------------------+-- | Parse and print back an expression.+replParse :: RState -> String -> HL.InputT IO ()+replParse state str+ = do   result  <- liftIO $ replParseExp state str+        case result of+         Nothing+          -> replLoop state++         Just xx+          -> do liftIO  $ TL.putStrLn+                        $ BL.toLazyText+                        $ Source.buildExp Source.CtxTop xx+                HL.outputStr "\n"++                replLoop state+++-------------------------------------------------------------------------------+-- | Parse an expression and push down substitutions.+replPush :: RState -> String -> HL.InputT IO ()+replPush state str+ = do   result  <- liftIO $ replParseExp state str+        case result of+         Nothing -> replLoop state+         Just xx -> replPush_next state xx+++-- | Advance the train pusher.+replPush_next :: RState -> RExp -> HL.InputT IO ()+replPush_next state xx+ = case pushDeep xx of+        Nothing -> replLoop $ state { stateMode = ModeNone }+        Just xx'+         -> do  liftIO  $ TL.putStrLn+                        $ BL.toLazyText+                        $ Source.buildExp Source.CtxTop xx'++                replLoop $ state { stateMode = ModePush xx' }+++-------------------------------------------------------------------------------+-- | Parse an expression and single-step it.+replStep :: RState -> String -> HL.InputT IO ()+replStep state str+ = replLoadExp state str replStep_next++-- | Advance the single stepper.+replStep_next+        :: RState -> RConfig -> RExp+        -> HL.InputT IO ()++replStep_next state config xx+ = do   erx     <- liftIO $ Step.step config (stateWorld state) xx+        case erx of+         Left Step.ResultDone+          -> replLoop $ state { stateMode = ModeNone }++         Left (Step.ResultError msg)+          -> do  HL.outputStrLn+                         $ Text.unpack+                         $ Text.pack "error: " <> msg++         Right xx'+          -> do  liftIO  $ TL.putStrLn+                         $ BL.toLazyText+                         $ Source.buildExp Source.CtxTop xx'++                 replLoop $ state { stateMode = ModeStep config xx' }+++-------------------------------------------------------------------------------+-- | Parse an expression and normalize it.+replSteps :: RState -> String -> HL.InputT IO ()+replSteps state str+ = replLoadExp state str replSteps_next++-- | Advance the evaluator stepper.+replSteps_next+        :: RState -> RConfig -> RExp+        -> HL.InputT IO ()++replSteps_next state config xx+ = do   erx     <- liftIO $ Step.steps config (stateWorld state) xx+        case erx of+         Left msg+          -> do  HL.outputStrLn+                         $ Text.unpack+                         $ Text.pack "error: " <> msg++         Right xx'+          -> do  liftIO  $ TL.putStrLn+                         $ BL.toLazyText+                         $ Source.buildExp Source.CtxTop xx'++                 replLoop $ state { stateMode = ModeNone }+++-------------------------------------------------------------------------------+-- | Parse an expression and normalize it,+--   printing out each intermediate state.+replTrace :: RState -> String -> HL.InputT IO ()+replTrace state str+ = replLoadExp state str replTrace_next++-- | Advance the evaluator stepper.+replTrace_next+        :: RState -> RConfig -> RExp+        -> HL.InputT IO ()++replTrace_next state config !xx0+ = loop xx0+ where+  loop !xx+   = do erx <- liftIO $ Step.step config (stateWorld state) xx+        case erx of+         Left (Step.ResultError msg)+          -> do  HL.outputStrLn+                  $ Text.unpack+                  $ Text.pack "error: " <> msg++         Left Step.ResultDone+          -> replLoop $ state { stateMode = ModeNone }++         Right xx'+          -> do  liftIO  $ TL.putStrLn+                         $ BL.toLazyText+                         $ Source.buildExp Source.CtxTop xx'++                 loop xx'++-------------------------------------------------------------------------------+replLoadExp+        :: RState -> String+        -> (RState -> RConfig -> RExp -> HL.InputT IO ())+        -> HL.InputT IO ()+replLoadExp state str eat+ = do   result  <- liftIO $ replParseExp state str+        case result of+         Nothing -> replLoop state++         Just xx+          -> let+                decls   = Map.fromList+                        $ [ (n, x) | DeclMac n x <- stateDecls state ]++                prims   = Map.fromList+                        $ [ (Prim.primEvalName p, p) | p <- Prim.primOps ]++                config  = Step.Config+                        { Step.configUnderLambdas = True+                        , Step.configHeadArgs     = True+                        , Step.configDeclsMac     = decls+                        , Step.configPrims        = prims }++              in eat state config xx+++-------------------------------------------------------------------------------+replParseExp :: RState -> String -> IO (Maybe RExp)+replParseExp _state str+ = do   let (ts, _loc, _csRest)+                = Source.lexTokens (Source.L 1 1) str++        let config+                = Source.Config+                { Source.configReadSym  = Just+                , Source.configReadPrm  = Prim.readPrim Prim.primNames }++        case Source.parseExp config ts of+         Left err+          -> do liftIO  $ putStrLn+                        $ "parse error\n"+                        ++ Source.pprParseError err+                return Nothing++         Right xx+          -> return (Just xx)+
+ SMR/Core/Codec.hs view
@@ -0,0 +1,220 @@++-- | Utilities for working with binary encoded Shimmer trees.+--+--   The grammar for the binary format is as follows:+--+-- @+-- File    ::= '53' '4d' '52' '31' Seq[Decl]       (Shimmer File: \"SMR1\" in ASCII, then Decls)+--+-- Decl    ::= (dmac)    \'d0\' Name Exp             (Macro declaration)+--          |  (dset)    \'d1\' Name Exp             (Set declaration)+--+-- Var     ::= (var)     \'8N\' Word8^N              (Short Varible,       N <= 15)+--+-- Abs     ::= (abs)     \'9N\' Exp^N                (Short Abstraction,   N <= 15)+--+-- App     ::= (app)     \'aN\' Exp^N                (Packed Application,  N <= 15)+--+-- Exp     ::= (ref)     \'b0\' Ref                  (External reference)+--          |  (key)     \'b1\' Key Exp              (Keyword  application)+--          |  (app)     \'b2\' Exp Seq[Exp]         (Function application)+--          |  (var)     \'b3\' Name Bump            (Variable with bump counter)+--          |  (abs)     \'b4\' Seq[Param] Exp       (Function abstraction)+--          |  (sub)     \'b5\' Seq[Car] Exp         (Substitution train)+--          |            Var                       (Short circuit to Var)+--          |            Abs                       (Short circuit to Abs)+--          |            App                       (Short circuit to App)+--          |            Ref                       (Short circuit to Ref)+--+-- Key     ::= (box)     \'b6\'                      (Box keyword)+--          |  (run)     \'b7\'                      (Run keyword)+--+-- Param   ::= (pval)    \'b8\' Name                 (call-by-value parameter)+--          |  (pnam)    \'b9\' Name                 (call-by-name  parameter)+--+-- Car     ::= (csim)    \'ba\' Seq[SnvBind]         (Simultaneous substitution)+--          |  (crec)    \'bb\' Seq[SnvBind]         (Recursive substitution)+--          |  (cups)    \'bc\' Seq[UpsBump]         (Lifting specifiers)+--+-- SnvBind ::= (svar)    \'bd\' Name Bump Exp        (Substitute for variable)+--          |  (snom)    \'be\' Nom Exp              (Substitute for nominal reference)+--+-- UpsBump ::= (ups)     \'bf\' Name Bump Bump       (Lifting specifier)+--+-- Ref     ::= (sym)     \'c0\' Seq[Word8]           (Symbol reference)+--          |  (prm)     \'c1\' Seq[Word8]           (Primitive reference)+--          |  (txt)     \'c2\' Seq[Word8]           (Text reference)+--          |  (mac)     \'c3\' Seq[Word8]           (Macro reference)+--          |  (set)     \'c4\' Seq[Word8]           (Set reference)+--          |  (nom)     \'c5\' Nom                  (Nominal reference)+--          |            Name                      (Short circuit to Sym Name)+--+-- Prim    ::= (unit)    \'e0\'                      (Unit value)+--          |  (list)    \'e1\'                      (List constructor tag)+--          |  (true)    \'e2\'                      (True value)+--          |  (false)   \'e3\'                      (False value)+--+--          |  (word8)   \'e4\' Word8                ( 8-bit word value)+--          |  (word16)  \'e5\' Word16               (16-bit word value)+--          |  (word32)  \'e6\' Word32               (32-bit word value)+--          |  (word64)  \'e7\' Word64               (64-bit word value)+--+--          |  (int8)    \'e8\' Int8                 ( 8-bit  int value)+--          |  (int16)   \'e9\' Int16                (16-bit  int value)+--          |  (int32)   \'ea\' Int32                (32-bit  int value)+--          |  (int64)   \'eb\' Int64                (64-bit  int value)+--+--          |  (float32) \'ec\' Float32              (32-bit float value)+--          |  (float64) \'ed\' Float64              (64-bit float value)+--+--          |  (named)   \'ee\' Name                 (Named primitive)+--          |  (words)   \'ef\' Name Seq[Word8]      (Packed raw words with type name)+--+-- Seq[A]  ::= (seqN)    \'fN\' A*                   (N-count then sequence of A things, N <= 13)+--          |  (seq8)    \'fd\' Word8  A*            ( 8-bit count then sequence of A things)+--          |  (seq16)   \'fe\' Word16 A*            (16-bit count then sequence of A things)+--          |  (seq32)   \'ff\' Word32 A*            (32-bit count then sequence of A things)+--+-- Name    ::= Seq[Word8]                          (Name)+--+-- Bump    ::= Word16                              (Bump counter)+--+-- Nom     ::= Word32                              (Nominal constant)+--+-- @+module SMR.Core.Codec+        ( -- * Pack+          packFileDecls+        , packDecl+        , packExp+        , packRef++          -- * Unpack+        , unpackFileDecls+        , unpackDecl+        , unpackExp+        , unpackRef++          -- * Raw Size+        , sizeOfFileDecls+        , sizeOfDecl, sizeOfExp, sizeOfRef++          -- * Raw Poke+        , Poke+        , pokeFileDecls+        , pokeDecl, pokeExp, pokeRef++          -- * Raw Peek+        , Peek+        , peekFileDecls+        , peekDecl, peekExp, peekRef)+where+import SMR.Core.Codec.Size+import SMR.Core.Codec.Poke+import SMR.Core.Codec.Peek+import SMR.Core.Exp+import SMR.Prim.Name+import Data.Text                        (Text)+import qualified Foreign.Marshal.Utils  as F+import qualified Foreign.Marshal.Alloc  as F+import qualified Foreign.Ptr            as F+import qualified System.IO.Unsafe       as System+import qualified Data.ByteString        as BS+import qualified Data.ByteString.Unsafe as BS++-- Pack -------------------------------------------------------------------------------------------+-- | Pack a list of `Decl` into a `ByteString`, including the file header.+packFileDecls :: [Decl Text Prim] -> BS.ByteString+packFileDecls decls+ = System.unsafePerformIO+ $ do   let nBytes = sizeOfFileDecls decls+        buf     <- F.mallocBytes nBytes+        _       <- pokeFileDecls decls (F.castPtr buf)+        BS.unsafePackMallocCStringLen (buf, nBytes)+{-# NOINLINE packFileDecls #-}+++-- | Pack a `Decl` into a `ByteString`.+packDecl :: Decl Text Prim -> BS.ByteString+packDecl xx+ = System.unsafePerformIO+ $ do   let nBytes = sizeOfDecl xx+        buf     <- F.mallocBytes nBytes+        _       <- pokeDecl xx (F.castPtr buf)+        BS.unsafePackMallocCStringLen (buf, nBytes)+{-# NOINLINE packDecl #-}+++-- | Pack an `Exp` into a `ByteString`.+packExp :: Exp Text Prim -> BS.ByteString+packExp xx+ = System.unsafePerformIO+ $ do   let nBytes = sizeOfExp xx+        buf     <- F.mallocBytes nBytes+        _       <- pokeExp xx (F.castPtr buf)+        BS.unsafePackMallocCStringLen (buf, nBytes)+{-# NOINLINE packExp #-}+++-- | Pack a `Ref` into a `ByteString`.+packRef :: Ref Text Prim -> BS.ByteString+packRef xx+ = System.unsafePerformIO+ $ do   let nBytes = sizeOfRef xx+        buf     <- F.mallocBytes nBytes+        _       <- pokeRef xx (F.castPtr buf)+        BS.unsafePackMallocCStringLen (buf, nBytes)+{-# NOINLINE packRef #-}+++-- Unpack -----------------------------------------------------------------------------------------+-- | Unpack a list of `Decl` into a ByteString, including the file header.+--+--   If the packed data is malformed then `error`.+unpackFileDecls :: BS.ByteString -> [Decl Text Prim]+unpackFileDecls bs+ = System.unsafePerformIO+ $ BS.unsafeUseAsCStringLen bs $ \(buf, nBytes)+ -> do  (decls, _, _) <- peekFileDecls (F.castPtr buf) nBytes+        return decls+{-# NOINLINE unpackFileDecls #-}+++-- | Unpack a `Decl` from a ByteString.+--+--   If the packed data is malformed then `error`.+unpackDecl :: BS.ByteString -> Decl Text Prim+unpackDecl bs+ = System.unsafePerformIO+ $ BS.unsafeUseAsCStringLen bs $ \(buf, nBytes)+ -> do  (decl, _, _) <- peekDecl (F.castPtr buf) nBytes+        return decl+{-# NOINLINE unpackDecl #-}+++-- | Unpack an `Exp` into a ByteString.+--+--   If the packed data is malformed then `error`.+unpackExp :: BS.ByteString -> Exp Text Prim+unpackExp bs+ = System.unsafePerformIO+ $ BS.unsafeUseAsCStringLen bs $ \(buf, nBytes)+ -> do  (exp, _, _) <- peekExp (F.castPtr buf) nBytes+        return exp+{-# NOINLINE unpackExp #-}+++-- | Unpack a `Ref` from a ByteString.+--+--   If the packed data is malformed then `error`.+unpackRef :: BS.ByteString -> Ref Text Prim+unpackRef bs+ = System.unsafePerformIO+ $ BS.unsafeUseAsCStringLen bs $ \(buf, nBytes)+ -> do  (ref, _, _) <- peekRef (F.castPtr buf) nBytes+        return ref+{-# NOINLINE unpackRef #-}++++
+ SMR/Core/Codec/Peek.hs view
@@ -0,0 +1,710 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleInstances #-}+module SMR.Core.Codec.Peek+        ( type Peek+        , peekFileDecls+        , peekDecl+        , peekExp+        , peekRef)+where+import SMR.Prim.Op.Base+import SMR.Core.Codec.Word+import SMR.Core.Exp++import qualified Foreign.Marshal.Utils          as F+import qualified Foreign.Marshal.Alloc          as F+import qualified Foreign.Storable               as F+import qualified Foreign.Ptr                    as F++import qualified Data.Text                      as T+import qualified Data.Text.Encoding             as T+import qualified Data.ByteString.Unsafe         as BS++import Control.Monad+import Foreign.Ptr+import Data.Text                                (Text)+import Data.Bits+import Data.Word+import Data.Int+import Numeric++---------------------------------------------------------------------------------------------------+-- | Type of a function that peeks an `a` thing from memory.+--+--   It takes the current pointer and count of remaining bytes in the buffer,+--   returns new pointer and remaining bytes.+--+type Peek a = Ptr Word8 -> Int -> IO (a, Ptr Word8, Int)+++---------------------------------------------------------------------------------------------------+-- | Peek a list of `Decl` from memory, including the SMR file header.+--+--   If the packed data is malformed then `error`.+peekFileDecls :: Peek [Decl Text Prim]+peekFileDecls !p0 !n0+ = do   (b0, p1, n1) <- peekWord8 p0 n0+        (b1, p2, n2) <- peekWord8 p1 n1+        (b2, p3, n3) <- peekWord8 p2 n2+        (b3, p4, n4) <- peekWord8 p3 n3+        when ( b0 /= 0x53 || b1 /= 0x4d || b2 /= 0x52 || b3 /= 0x31)+         $ error "shimmer.peekFileDecls: bad magic"++        (ds, p5, n5) <- peekList peekDecl p4 n4+        return (ds, p5, n5)+{-# NOINLINE peekFileDecls #-}+++-- | Peek a `Decl` from memory.+--+--   If the packed data is malformed then `error`.+peekDecl :: Peek (Decl Text Prim)+peekDecl !p0 !n0+ = do   (b0, p1, n1) <- peekWord8 p0 n0+        p1 `seq` case b0 of+         0xd0+          -> do (tx,  p2, n2) <- peekName p1 n1+                (x,   p3, n3) <- peekExp  p2 n2+                return (DeclMac tx x, p3, n3)++         0xd1+          -> do (tx,  p2, n2) <- peekName p1 n1+                (x,   p3, n3) <- peekExp  p2 n2+                return (DeclSet tx x, p3, n3)++         _ -> error $ failHeaderByte "peekDecl" b0 n0+{-# NOINLINE peekDecl #-}+++---------------------------------------------------------------------------------------------------+-- | Peek an `Exp` from memory.+--+--   If the packed data is malformed then `error`.+peekExp :: Peek (Exp Text Prim)+peekExp !p0 !n0+ = do   (b0, p1, n1) <- peekWord8 p0 n0+        p1 `seq` case b0 of+         0xb0+          -> do (r,   p2, n2) <- peekRef p1 n1+                return  (XRef r, p2, n2)++         0xb1+          -> do (key, p2, n2) <- peekKey p1 n1+                (xx,  p3, n3) <- peekExp p2 n2+                return  (XKey key xx, p3, n3)++         0xb2+          -> do (x1,  p2, n2) <- peekExp  p1 n1+                (xs,  p3, n3) <- peekList peekExp p2 n2+                return  (XApp x1 xs, p3, n3)++         0xb3+          -> do (n,   p2, n2) <- peekName p1 n1+                (i,   p3, n3) <- peekBump p2 n2+                return  (XVar n i, p3, n3)++         0xb4+          -> do (ps,  p2, n2) <- peekList peekParam p1 n1+                (x,   p3, n3) <- peekExp  p2 n2+                return  (XAbs ps x, p3, n3)++         0xb5+          -> do (cs,  p2, n2) <- peekList peekCar p1 n1+                (x,   p3, n3) <- peekExp  p2 n2+                return  (XSub cs x, p3, n3)++         _ -> case b0 .&. 0x0f0 of+                -- Short Variable Name.+                0x80+                 -> do  (tx, p2, n2) <- peekVar p0 n0+                        return (XVar tx 0, p2, n2)++                -- Short Abstraction.+                0x90    -> peekAbs p0 n0++                -- Short Application.+                0xa0    -> peekApp p0 n0++                -- Short Circuit to Ref.+                0xc0+                 -> do  (r, p2, n2) <- peekRef p0 n0+                        return (XRef r, p2, n2)++                -- Short Circuit to Sym.+                0xf0+                 -> do  (tx, p2, n2) <- peekText p0 n0+                        return (XRef $ RSym tx, p2, n2)++                _ -> failHeaderByte "peekExp" b0 n0++{-# NOINLINE peekExp #-}+++-- | Peek a short abstraction from memory.+peekAbs :: Peek (Exp Text Prim)+peekAbs p0 n0+ | n0 >= 1+ = do   (b0, p1, n1) <- peekWord8' p0 n0++        when ((b0 .&. 0x0f0) /= 0x90)+         $ failHeaderByte "peekAbs" b0 n0++        go    (fromIntegral $ b0 .&. 0x00f) [] p1 n1++ | otherwise+ = error "shimmer.peekAbs: short header"++ where  go (0 :: Int) acc p n+         = do   (x, p2, n2) <- peekExp p n+                return (XAbs (reverse acc) x, p2, n2)++        go i acc p n+         = do   (x, p', n') <- peekParam p n+                go (i - 1) (x : acc) p' n'+        {-# NOINLINE go #-}+{-# INLINE peekAbs #-}+++-- | Peek a short application from memory.+peekApp :: Peek (Exp Text Prim)+peekApp p0 n0+ | n0 >= 1+ = do   (b0, p1, n1) <- peekWord8' p0 n0+        when ((b0 .&. 0x0f0) /= 0xa0)+         $ failHeaderByte "peekApp" b0 n0++        (x0, p2, n2) <- peekExp    p1 n1+        go  x0 (fromIntegral $ b0 .&. 0x00f) [] p2 n2++ | otherwise+ = error "shimmer.peekApp: short header"++ where  go x0 (0 :: Int) acc p n+         = do   return (XApp x0 (reverse acc), p, n)++        go x0 i acc p n+         = do   (x, p', n') <- peekExp p n+                go x0 (i - 1) (x : acc) p' n'+        {-# NOINLINE go #-}+{-# INLINE peekApp #-}+++-- | Peek a `Key` from memory.+peekKey :: Peek Key+peekKey !p0 !n0+ = do   (b0, p1, n1) <- peekWord8 p0 n0+        p1 `seq` case b0 of+         0xb6   -> return (KBox, p1, n1)+         0xb7   -> return (KRun, p1, n1)+         _      -> failHeaderByte "peekKey" b0 n0+{-# INLINE peekKey #-}+++-- | Peek a `Param` from memory.+peekParam :: Peek Param+peekParam !p0 !n0+ = do   (b0, p1, n1) <- peekWord8 p0 n0+        p1 `seq` case b0 of+         0xb8+          -> do (tx, p2, n2) <- peekName p1 n1+                return (PParam tx PVal, p2, n2)++         0xb9+          -> do (tx, p2, n2) <- peekName p1 n1+                return (PParam tx PExp, p2, n2)++         _ -> failHeaderByte "peekParam" b0 n0+{-# INLINE peekParam #-}+++-- | Peek a `Car` from memory.+peekCar :: Peek (Car Text Prim)+peekCar !p0 !n0+ = do   (b0, p1, n1) <- peekWord8 p0 n0+        p1 `seq` case b0 of+         0xba+          -> do (sbs, p2, n2) <- peekList peekSnvBind p1 n1+                return (CSim (SSnv sbs), p2, n2)++         0xbb+          -> do (sbs, p2, n2) <- peekList peekSnvBind p1 n1+                return (CRec (SSnv sbs), p2, n2)++         0xbc+          -> do (ups, p2, n2) <- peekList peekUpsBump p1 n1+                return (CUps (UUps ups), p2, n2)++         _ -> failHeaderByte "peekCar" b0 n1+{-# INLINE peekCar #-}+++-- | Peek an `SnvBind` from memory.+peekSnvBind :: Peek (SnvBind Text Prim)+peekSnvBind !p0 !n0+ = do   (b0, p1, n1) <- peekWord8 p0 n0+        p1 `seq` case b0 of+         0xbd+          -> do (n, p2, n2) <- peekName p1 n1+                (d, p3, n3) <- peekBump p2 n2+                (x, p4, n4) <- peekExp  p3 n3+                return (BindVar n d x, p4, n4)++         0xbe+          -> do (n, p2, n2) <- peekNom  p1 n1+                (x, p3, n3) <- peekExp  p2 n2+                return (BindNom n x,   p3, n3)++         _ -> failHeaderByte "peekSnvBind" b0 n1+{-# INLINE peekSnvBind #-}+++-- | Peek an `UpsBump` from memory.+peekUpsBump :: Peek UpsBump+peekUpsBump !p0 !n0+ = do   (b0, p1, n1) <- peekWord8 p0 n0++        when (b0 /= 0xbf)+         $ failHeaderByte "peekUpsBump" b0 n1++        (n,  p2, n2) <- peekName  p1 n1+        (d,  p3, n3) <- peekBump  p2 n2+        (i,  p4, n4) <- peekBump  p3 n3+        return  $ (((n, d), i), p4, n4)+{-# INLINE peekUpsBump #-}+++---------------------------------------------------------------------------------------------------+-- | Peek a `Ref` from memory.+--+--   If the packed data is malformed then `error`.+peekRef :: Peek (Ref Text Prim)+peekRef !p0 !n0+ = do   (b0, p1, n1) <- peekWord8 p0 n0+        p1 `seq` case b0 of+         0xc0+          -> do (tx, p2, n2) <- peekText p1 n1+                return (RSym tx, p2, n2)++         0xc1+          -> do (m,  p2, n2) <- peekPrim p1 n1+                return (RPrm m,  p2, n2)++         0xc2+          -> do (tx, p2, n2) <- peekText p1 n1+                return (RTxt tx, p2, n2)++         0xc3+          -> do (tx, p2, n2) <- peekText p1 n1+                return (RMac tx, p2, n2)++         0xc4+          -> do (tx, p2, n2) <- peekText p1 n1+                return (RSet tx, p2, n2)++         0xc5+          -> do (i,  p2, n2) <- peekNom  p1 n1+                return (RNom i,  p2, n2)++         -- Short Circuit Sym.+         _+          -> do (r,   p1', n1') <- peekName p0 n0+                return (RSym r, p1', n1')+{-# INLINE peekRef #-}+++---------------------------------------------------------------------------------------------------+-- | Peek a `Name` from memory.+peekName :: Peek Name+peekName !p !n+ = do   peekText p n+{-# INLINE peekName #-}+++-- | Peek a `Bump` counter from memory.+peekBump :: Peek Integer+peekBump !p0 !n0+ = do   (i, p1, n1) <- peekWord16 p0 n0+        return (fromIntegral i, p1, n1)+{-# INLINE peekBump #-}+++-- | Peek a `Nom` from memory.+peekNom :: Peek Integer+peekNom !p0 !n0+ = do   (i, p1, n1) <- peekWord32 p0 n0+        return (fromIntegral i, p1, n1)+{-# INLINE peekNom #-}+++---------------------------------------------------------------------------------------------------+-- | Peek a prim from memory.+peekPrim :: Peek Prim+peekPrim !p0 !n0+ | n0 >= 1+ = do   (b0, p1, n1) <- peekWord8' p0 n0+        p1 `seq` case b0 of+         0xe0   -> return (PrimTagUnit,         p1, n1)+         0xe1   -> return (PrimTagList,         p1, n1)+         0xe2   -> return (PrimLitBool True,    p1, n1)+         0xe3   -> return (PrimLitBool False,   p1, n1)++         -- WordN ----+         0xe4+          -> do (w8, p2, n2) <- peekWord8 p1 n1+                return (PrimLitWord8   w8, p2, n2)++         0xe5+          -> do (w16, p2, n2) <- peekWord16 p1 n1+                return (PrimLitWord16 w16, p2, n2)++         0xe6+          -> do (w32, p2, n2) <- peekWord32 p1 n1+                return (PrimLitWord32 w32, p2, n2)++         0xe7+          -> do (w64, p2, n2) <- peekWord64 p1 n1+                return (PrimLitWord64 w64, p2, n2)++         -- IntN -----+         0xe8+          -> do (w8, p2, n2)  <- peekWord8 p1 n1+                return (PrimLitInt8  $ fromIntegral  w8, p2, n2)++         0xe9+          -> do (w16, p2, n2) <- peekWord16 p1 n1+                return (PrimLitInt16 $ fromIntegral w16, p2, n2)++         0xea+          -> do (w32, p2, n2) <- peekWord32 p1 n1+                return (PrimLitInt32 $ fromIntegral w32, p2, n2)++         0xeb+          -> do (w64, p2, n2) <- peekWord64 p1 n1+                return (PrimLitInt64 $ fromIntegral w64, p2, n2)++         -- FloatN -----+         0xec+          -> do (f32, p2, n2) <- peekFloat32 p1 n1+                return (PrimLitFloat32 f32, p2, n2)++         0xed+          -> do (f64, p2, n2) <- peekFloat64 p1 n1+                return (PrimLitFloat64 f64, p2, n2)++         -----------+         0xee+          -> do (tx, p2, n2) <- peekText p1 n1+                return  (PrimOp tx, p2, n2)++         0xef+          -> do (tx, p2, n2) <- peekText p1 n1+                case T.unpack tx of+                 "nat"+                  -> do (ls, p3, n3) <- peekList peekWord8 p2 n2+                        case ls of+                         [x0, x1, x2, x3, x4, x5, x6, x7]+                          -> do let w   =   to64 x0 `shiftL` 56+                                        .|. to64 x1 `shiftL` 48+                                        .|. to64 x2 `shiftL` 40+                                        .|. to64 x3 `shiftL` 32+                                        .|. to64 x4 `shiftL` 24+                                        .|. to64 x5 `shiftL` 16+                                        .|. to64 x6 `shiftL` 8+                                        .|. to64 x7+                                return (PrimLitNat $ fromIntegral w, p3, n3)++                 "int"+                  -> do (ls, p3, n3) <- peekList peekWord8 p2 n2+                        case ls of+                         [x0, x1, x2, x3, x4, x5, x6, x7]+                          -> do let w   =   to64 x0 `shiftL` 56+                                        .|. to64 x1 `shiftL` 48+                                        .|. to64 x2 `shiftL` 40+                                        .|. to64 x3 `shiftL` 32+                                        .|. to64 x4 `shiftL` 24+                                        .|. to64 x5 `shiftL` 16+                                        .|. to64 x6 `shiftL` 8+                                        .|. to64 x7++                                F.allocaBytes 8 $ \pp+                                 -> do  F.poke (F.castPtr pp :: Ptr Word64) w+                                        i64 <- F.peek (F.castPtr pp :: Ptr Int64)+                                        return (PrimLitInt (fromIntegral i64), p3, n3)++                         _ -> error "shimmer.peekPrim: invalid payload"++                 s -> error $ "shimmer.peekPrim: unknown tag " ++ show s++         _ -> failHeaderByte "peekPrim" b0 n1++ | otherwise+ = error "shimmer.peekPrim: short header"+{-# INLINE peekPrim #-}+++---------------------------------------------------------------------------------------------------+-- | Peek a list of things from memory.+peekList :: Peek a -> Peek [a]+peekList peekA p0 n0+ | n0 >= 1+ = do   (b0, p1, n1) <- peekWord8' p0 n0++        case b0 of+         0xfd+          | n1 >= 1+          -> do nElems <- fmap fromIntegral $ peek8  p0 1+                go nElems [] (F.plusPtr p0 2) (n1 - 1)++         0xfe+          | n1 >= 2+          -> do nElems <- fmap fromIntegral $ peek16 p0 1+                go nElems [] (F.plusPtr p0 3) (n1 - 2)++         0xff+          | n1 >= 4+          -> do nElems <- fmap fromIntegral $ peek32 p0 1+                go nElems [] (F.plusPtr p0 5) (n1 - 4)++         _ |  (b0 .&. 0x0f0) == 0xf0+           -> let nElems = fromIntegral (b0 .&. 0x0f)+              in  go nElems [] p1 n1++           | otherwise+           -> failHeaderByte "peekList" b0 n0++ | otherwise+ = error "shimmer.peekList: short header"++ where  go (0 :: Int) acc p n+         = return (reverse acc, p, n)++        go i acc p n+         = do   (x, p', n') <- peekA p n+                go (i - 1) (x : acc) p' n'+        {-# NOINLINE go #-}++{-# INLINE peekList #-}+++---------------------------------------------------------------------------------------------------+-- | Peek a short variable name from memory.+peekVar  :: Peek Text+peekVar !p0 !n0+ | n0 >= 1+ = do   (b0, p1, n1) <- peekWord8' p0 n0++        when ((b0 .&. 0x0f0) /= 0x80)+         $ failHeaderByte "peekVar" b0 n0++        let nBytes  = fromIntegral $ b0 .&. 0x0f+        buf     <- F.mallocBytes nBytes+        F.copyBytes buf (F.castPtr p1) nBytes+        bs      <- BS.unsafePackMallocCStringLen (buf, nBytes)+        return (T.decodeUtf8 bs, F.plusPtr p1 nBytes, n1 - nBytes)++ | otherwise+ = error "shimmer.peekVar: short header"+++-- | Peek a text value from memory as UTF8 characters.+peekText :: Peek Text+peekText !p0 !n0+ | n0 >= 1+ = do   (b0, p1, n1) <- peekWord8' p0 n0+        case b0 of++         0xfd+          | n1 >= 1+          -> do nBytes  <- fmap fromIntegral $ peek8 p0 1+                buf     <- F.mallocBytes nBytes+                let p2  =  F.plusPtr p0 2+                let n2  =  n0 - 2++                when (not (n2 >= nBytes))+                 $ error $ "shimmer.peekText.fd: pointer out of range"++                F.copyBytes buf p2 nBytes+                bs      <- BS.unsafePackMallocCStringLen (buf, nBytes)+                return (T.decodeUtf8 bs, F.plusPtr p2 nBytes, n2 - nBytes)++         0xfe+          | n1 >= 2+          -> do nBytes  <- fmap fromIntegral $ peek16 p0 1+                buf     <- F.mallocBytes nBytes+                let p2  =  F.plusPtr p0 3+                let n2  =  n0 - 3++                when (not (n2 >= nBytes))+                 $ error "shimmer.peekText.fe: pointer out of range"++                F.copyBytes buf p2 nBytes+                bs      <- BS.unsafePackMallocCStringLen (buf, nBytes)+                return (T.decodeUtf8 bs, F.plusPtr p2 nBytes, n2 - nBytes)++         0xff+          | n1 >= 4+          -> do nBytes  <- fmap fromIntegral $ peek32 p0 1+                buf     <- F.mallocBytes nBytes+                let p2  =  F.plusPtr p0 5+                let n2  =  n0 - 5++                when (not (n2 >= nBytes))+                 $ error "shimmer.peekText.ff: pointer out of range"++                F.copyBytes buf p2 nBytes+                bs      <- BS.unsafePackMallocCStringLen (buf, nBytes)+                return (T.decodeUtf8 bs, F.plusPtr p2 nBytes, n2 - nBytes)++         -- Short text.+         _+          -> do when ((b0 .&. 0x0f0) /= 0xf0)+                 $ error $ "shimmer.peekVar.fN: invalid header " ++ show b0++                let nBytes  = fromIntegral $ b0 .&. 0x0f+                buf     <- F.mallocBytes nBytes+                F.copyBytes buf (F.castPtr p1) nBytes+                bs      <- BS.unsafePackMallocCStringLen (buf, nBytes)+                return (T.decodeUtf8 bs, F.plusPtr p1 nBytes, n1 - nBytes)++ | otherwise+ = error "shimmer.peekText.start: pointer out of range"+{-# NOINLINE peekText #-}+++---------------------------------------------------------------------------------------------------+-- | Peek a `Word8` from memory, in network byte order, with bounds check.+peekWord8  :: Peek Word8+peekWord8 p n+ | n >= 1       = peekWord8' p n+ | otherwise    = error "shimmer.peekWord8: pointer out of bounds"+{-# NOINLINE peekWord8 #-}+++-- | Peek a `Word8` from memory, in network byte order, with no bounds check.+peekWord8' :: Peek Word8+peekWord8' p n+ = do   w  <- F.peek p+        return (w, F.plusPtr p 1, n - 1)+{-# INLINE peekWord8' #-}+++-- | Peek a `Word16` from memory, in network byte order, with bounds check.+peekWord16  :: Peek Word16+peekWord16 p n+ | n >= 2       = peekWord16' p n+ | otherwise    = error "shimmer.peekWord16: pointer out of bounds"+{-# NOINLINE peekWord16 #-}+++-- | Peek a `Word16` from memory, in network byte order, with no bound check.+peekWord16' :: Peek Word16+peekWord16' p n+ = do   w  <- fmap fromBE16 $ peek16 p 0+        return (w, F.plusPtr p 2, n - 2)+{-# INLINE peekWord16' #-}+++-- | Peek a `Word32` from memory, in network byte order, with bounds check.+peekWord32  :: Peek Word32+peekWord32 p n+ | n >= 4       = peekWord32' p n+ | otherwise    = error "shimmer.peekWord32: pointer out of bounds"+{-# NOINLINE peekWord32 #-}+++-- | Peek a `Word32` from memory, in network byte order, with no bounds check.+peekWord32' :: Peek Word32+peekWord32' p n+ = do   w  <- fmap fromBE32 $ peek32 p 0+        return (w, F.plusPtr p 4, n - 4)+{-# INLINE peekWord32' #-}+++-- | Peek a `Word64` from memory, in network byte order, with bounds check.+peekWord64  :: Peek Word64+peekWord64 p n+ | n >= 8       = peekWord64' p n+ | otherwise    = error "shimmer.peekWord64: pointer out of bounds"+{-# NOINLINE peekWord64 #-}+++-- | Peek a `Word64` from memory, in network byte order.+peekWord64' :: Peek Word64+peekWord64' p n+ = do   w  <- fmap fromBE64 $ peek64 p 0+        return (w, F.plusPtr p 8, n - 8)+{-# INLINE peekWord64' #-}+++-- | Peek a `Float32` from memory, in network byte order, with bounds check.+peekFloat32  :: Peek Float+peekFloat32 p0 n0+ | n0 >= 4+ = F.allocaBytes 4 $ \p'+ -> do  (w32, p1, n1) <- peekWord32' p0 n0+        F.poke (F.castPtr p' :: Ptr Word32) w32+        f32 <- F.peek (F.castPtr p' :: Ptr Float)+        return (f32, p1, n1)++ | otherwise    = error "shimmer.peekFloat32: pointer out of bounds"+{-# NOINLINE peekFloat32 #-}+++-- | Peek a `Float64` from memory, in network byte order, with bounds check.+peekFloat64  :: Peek Double+peekFloat64 p0 n0+ | n0 >= 8+ = F.allocaBytes 8 $ \p'+ -> do  (w64, p1, n1) <- peekWord64' p0 n0+        F.poke (F.castPtr p' :: Ptr Word64) w64+        f64 <- F.peek (F.castPtr p' :: Ptr Double)+        return (f64, p1, n1)++ | otherwise    = error "shimmer.peekFloat64: pointer out of bounds"+{-# NOINLINE peekFloat64 #-}+++to16  :: Word8 -> Word16+to16 = fromIntegral+{-# INLINE to16 #-}+++to64  :: Word8 -> Word64+to64 = fromIntegral+{-# INLINE to64 #-}+++to32  :: Word8 -> Word32+to32 = fromIntegral+{-# INLINE to32 #-}+++peek8 :: Ptr a -> Int -> IO Word8+peek8 p o = F.peekByteOff p o+{-# INLINE peek8 #-}+++peek16 :: Ptr a -> Int -> IO Word16+peek16 p o = F.peekByteOff p o+{-# INLINE peek16 #-}+++peek32 :: Ptr a -> Int -> IO Word32+peek32 p o = F.peekByteOff p o+{-# INLINE peek32 #-}+++peek64 :: Ptr a -> Int -> IO Word64+peek64 p o = F.peekByteOff p o+{-# INLINE peek64 #-}+++-- Failure ----------------------------------------------------------------------------------------+failHeaderByte :: String -> Word8 -> Int -> a+failHeaderByte fn b n+ = error+ $ "shimmer." ++ fn+        ++ " invalid header byte "+        ++ showHex b "" ++ "@-" ++ showHex n ""
+ SMR/Core/Codec/Poke.hs view
@@ -0,0 +1,455 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleInstances #-}+module SMR.Core.Codec.Poke+        ( type Poke+        , pokeFileDecls+        , pokeDecl+        , pokeExp+        , pokeRef)+where+import SMR.Core.Codec.Word+import SMR.Prim.Op.Base+import SMR.Core.Exp++import qualified Foreign.Marshal.Utils          as F+import qualified Foreign.Marshal.Alloc          as F+import qualified Foreign.Storable               as F+import qualified Foreign.Ptr                    as F++import qualified Data.Text                      as T+import qualified Data.Text.Encoding             as T+import qualified Data.ByteString.Unsafe         as BS++import Data.Text                                (Text)+import Foreign.Ptr                              (Ptr)+import Control.Monad+import Data.Bits+import Data.Word+++---------------------------------------------------------------------------------------------------+-- | Type of a function that pokes an `a` thing into memory.+--+--   It takes a pointer to the next byte to use,+--   and returns an updated pointer.+--+type Poke a = a -> Ptr Word8 -> IO (Ptr Word8)+++---------------------------------------------------------------------------------------------------+-- | Poke a list of `Decl` into memory, including the SMR file header.+pokeFileDecls :: Poke [Decl Text Prim]+pokeFileDecls ds+        =   pokeWord8 0x53              -- 'S'+        >=> pokeWord8 0x4d              -- 'M'+        >=> pokeWord8 0x52              -- 'R'+        >=> pokeWord8 0x31              -- '1'+        >=> pokeList  pokeDecl ds+{-# NOINLINE pokeFileDecls #-}+++-- | Poke a `Decl` into memory.+pokeDecl :: Poke (Decl Text Prim)+pokeDecl xx+ = case xx of+        DeclMac name x+         ->     pokeWord8 0xd0 >=> pokeText name >=> pokeExp x++        DeclSet name x+         ->     pokeWord8 0xd1 >=> pokeText name >=> pokeExp x+{-# NOINLINE pokeDecl #-}+++---------------------------------------------------------------------------------------------------+-- | Poke an `Exp` into memory.+pokeExp :: Poke (Exp Text Prim)+pokeExp xx+ = case xx of+        -- Short circuit XRef.+        XRef ref+         ->     pokeRef ref++        XKey key x+         ->     pokeWord8 0xb1 >=> pokeKey key >=> pokeExp x++        XApp x1 xs+         -- Short circuit to App.+         | length xs <= 15+         ->     pokeApp (x1, xs)++         | otherwise+         ->     pokeWord8 0xb2 >=> pokeExp x1  >=> pokeList pokeExp xs++        XVar name i+         -- Short circuit to Var.+         | T.length name <= 15, i == 0+         ->     pokeVar name++         | otherwise+         ->     pokeWord8 0xb3 >=> pokeName name >=> pokeBump i++        XAbs ps x+         -- Short circuit to Abs+         | length ps <= 15+         ->     pokeAbs (ps, x)++         | otherwise+         ->     pokeWord8 0xb4 >=> pokeList pokeParam ps >=> pokeExp x++        XSub cs x+         ->     pokeWord8 0xb5 >=> pokeList pokeCar cs >=> pokeExp x+{-# NOINLINE pokeExp #-}+++-- | Poke an `Exp` abstraction into memory with packed length.+pokeAbs :: Poke ([Param], Exp Text Prim)+pokeAbs (ps, x)+ =      pokeWord8 (0x90 + fromIntegral (length ps))+         >=> go ps+         >=> pokeExp x++ where  go [] !p0 = return p0+        go (p : ps1) !p0+         = do   p1 <- pokeParam p p0+                go ps1 p1+        {-# NOINLINE go #-}+{-# INLINE pokeAbs #-}+++-- | Poke an `Exp` application into memory with packed length.+pokeApp :: Poke (Exp Text Prim, [Exp Text Prim])+pokeApp (x1, xs1)+ =      pokeWord8 (0xa0 + fromIntegral (length xs1))+         >=> pokeExp x1+         >=> go xs1++ where  go [] !p0 = return p0+        go (x : xs) !p0+         = do   p1 <- pokeExp x p0+                go xs p1+        {-# NOINLINE go #-}+{-# INLINE pokeApp #-}+++-- | Poke a `Key` into memory.+pokeKey :: Poke Key+pokeKey key+ = case key of+        KBox -> pokeWord8 0xb6+        KRun -> pokeWord8 0xb7+{-# INLINE pokeKey #-}+++-- | Poke a `Param` into memory.+pokeParam :: Poke Param+pokeParam pp+ = case pp of+        PParam tx PVal+         ->     pokeWord8 0xb8 >=> pokeName tx++        PParam tx PExp+         ->     pokeWord8 0xb9 >=> pokeName tx+{-# INLINE pokeParam #-}+++-- | Poke a `Car` into memory.+pokeCar :: Poke (Car Text Prim)+pokeCar car+ = case car of+        CSim (SSnv sbs)+         ->     pokeWord8 0xba >=> pokeList pokeSnvBind sbs++        CRec (SSnv sbs)+         ->     pokeWord8 0xbb >=> pokeList pokeSnvBind sbs++        CUps (UUps ups)+         ->     pokeWord8 0xbc >=> pokeList pokeUpsBump ups+{-# INLINE pokeCar #-}+++-- | Poke an `SnvBind` into memory.+pokeSnvBind :: Poke (SnvBind Text Prim)+pokeSnvBind !b+ = case b of+        BindVar n d x+         ->     pokeWord8 0xbd >=> pokeName n >=> pokeBump d >=> pokeExp x++        BindNom n x+         ->     pokeWord8 0xbe >=> pokeNom  n >=> pokeExp x+{-# INLINE pokeSnvBind #-}+++-- | Poke an `UpsBump` into memory.+pokeUpsBump :: Poke UpsBump+pokeUpsBump ((n, d), i)+ =      pokeWord8 0xbf >=> pokeName n >=> pokeBump d >=> pokeBump i+{-# INLINE pokeUpsBump #-}+++---------------------------------------------------------------------------------------------------+-- | Poke a `Var` into memory.+pokeVar :: Poke Text+pokeVar !tx !p0+ = do   let bs = T.encodeUtf8 tx+        BS.unsafeUseAsCStringLen bs $ \(pStr, nBytes)+         -> if nBytes <= 15 then+             do p1 <- pokeWord8 (0x80 + (fromIntegral nBytes)) p0+                F.copyBytes (F.castPtr p1) pStr nBytes+                return (F.plusPtr p1 nBytes)+            else error "shimmer.pokeVar: var length too long"+{-# INLINE pokeVar #-}+++-- | Poke a `Ref` into memory.+pokeRef :: Poke (Ref Text Prim)+pokeRef !r+ = case r of+        -- Short Circuit to Sym Name.+        RSym tx -> pokeName tx++        RPrm p  -> pokeWord8 0xc1 >=> pokePrim p+        RTxt tx -> pokeWord8 0xc2 >=> pokeName tx+        RMac tx -> pokeWord8 0xc3 >=> pokeName tx+        RSet tx -> pokeWord8 0xc4 >=> pokeName tx+        RNom i  -> pokeWord8 0xc5 >=> pokeNom  i+{-# INLINE pokeRef #-}+++---------------------------------------------------------------------------------------------------+-- | Peek a `Name` from memory.+pokeName :: Poke Name+pokeName !p n+ =      pokeText p n+{-# INLINE pokeName #-}+++-- | Poke a `Bump` into memory.+pokeBump :: Poke Integer+pokeBump !n !p+ = if n <= 2^(16 :: Int) then+    do  pokeWord16 (fromIntegral n) p+   else error "shimmer.pokeBump: bump counter too large."+{-# NOINLINE pokeBump #-}+++-- | Poke a `Nom` into memory.+pokeNom  :: Poke Integer+pokeNom !n !p+ = if n <= 2^(28 :: Int) then+    do  pokeWord32 (fromIntegral n) p+   else error "shimmer.pokeNom: nominal constant index too large."+{-# NOINLINE pokeNom #-}+++---------------------------------------------------------------------------------------------------+-- | Poke a prim into memory.+pokePrim :: Poke Prim+pokePrim !pp+ = case pp of+        PrimTagUnit             -> pokeWord8 0xe0+        PrimTagList             -> pokeWord8 0xe1++        PrimLitBool True        -> pokeWord8 0xe2+        PrimLitBool False       -> pokeWord8 0xe3++        PrimLitWord8  w8        -> pokeWord8 0xe4 >=> pokeWord8  w8+        PrimLitWord16 w16       -> pokeWord8 0xe5 >=> pokeWord16 w16+        PrimLitWord32 w32       -> pokeWord8 0xe6 >=> pokeWord32 w32+        PrimLitWord64 w64       -> pokeWord8 0xe7 >=> pokeWord64 w64++        PrimLitInt8   i8        -> pokeWord8 0xe8 >=> pokeWord8  (fromIntegral i8)+        PrimLitInt16  i16       -> pokeWord8 0xe9 >=> pokeWord16 (fromIntegral i16)+        PrimLitInt32  i32       -> pokeWord8 0xea >=> pokeWord32 (fromIntegral i32)+        PrimLitInt64  i64       -> pokeWord8 0xeb >=> pokeWord64 (fromIntegral i64)++        PrimLitFloat32 f        -> pokeWord8 0xec >=> pokeFloat32 f+        PrimLitFloat64 f        -> pokeWord8 0xed >=> pokeFloat64 f++        PrimOp tx               -> pokeWord8 0xee >=> pokeText tx++        -- TODO: handle arbitrary length nats instead of squashing into Word64.+        PrimLitNat n+         -> pokeWord8 0xef+                >=> pokeName (T.pack "nat")+                >=> pokeList pokeWord8+                        [ fromIntegral $ (n .&. 0xff00000000000000) `shiftR` 56+                        , fromIntegral $ (n .&. 0x00ff000000000000) `shiftR` 48+                        , fromIntegral $ (n .&. 0x0000ff0000000000) `shiftR` 40+                        , fromIntegral $ (n .&. 0x000000ff00000000) `shiftR` 32+                        , fromIntegral $ (n .&. 0x00000000ff000000) `shiftR` 24+                        , fromIntegral $ (n .&. 0x0000000000ff0000) `shiftR` 16+                        , fromIntegral $ (n .&. 0x000000000000ff00) `shiftR` 8+                        , fromIntegral $ (n .&. 0x00000000000000ff)]++        -- TOOD: handle arbitrary length ints instead of squashing into Word64.+        PrimLitInt n+         -> pokeWord8 0xef+                >=> pokeName (T.pack "int")+                >=> pokeList pokeWord8+                        [ fromIntegral $ (n .&. 0xff00000000000000) `shiftR` 56+                        , fromIntegral $ (n .&. 0x00ff000000000000) `shiftR` 48+                        , fromIntegral $ (n .&. 0x0000ff0000000000) `shiftR` 40+                        , fromIntegral $ (n .&. 0x000000ff00000000) `shiftR` 32+                        , fromIntegral $ (n .&. 0x00000000ff000000) `shiftR` 24+                        , fromIntegral $ (n .&. 0x0000000000ff0000) `shiftR` 16+                        , fromIntegral $ (n .&. 0x000000000000ff00) `shiftR` 8+                        , fromIntegral $ (n .&. 0x00000000000000ff)]+++{-# INLINE pokePrim #-}+++---------------------------------------------------------------------------------------------------+-- | Poke a list of things into memory, including size info.+pokeList :: Poke a -> Poke [a]+pokeList pokeA ls+ = do   let  n     = length ls+        if n < 13 then+         do     pokeWord8 (0xf0 + (fromIntegral n)) >=> go ls++        else if n <= 2^(8 :: Int) - 1+         then   pokeWord8 0xfd >=> pokeWord8  (fromIntegral n) >=> go ls++        else if n <= 2^(16 :: Int) - 1+         then   pokeWord8 0xfe >=> pokeWord16 (fromIntegral n) >=> go ls++        else if n <= 2^(28 :: Int)+         then   pokeWord8 0xff >=> pokeWord32 (fromIntegral n) >=> go ls++        else error "shimmer.pokeList: list too long."++ where  go [] !p0 = return p0+        go (x : xs) !p0+         = do   p1 <- pokeA x p0+                go xs p1+        {-# NOINLINE go #-}++{-# INLINE pokeList #-}+++---------------------------------------------------------------------------------------------------+-- | Poke a text value into memory as UTF8 characters.+pokeText :: Poke Text+pokeText !tx !p0+ = do   let bs = T.encodeUtf8 tx++        BS.unsafeUseAsCStringLen bs $ \(pStr, nBytes)+         -> if nBytes < 13 then+             do p1 <- pokeWord8 (0xf0 + (fromIntegral nBytes)) p0+                F.copyBytes (F.castPtr p1) pStr nBytes+                return (F.plusPtr p1 nBytes)++            else if nBytes <= 255 then+             do p1 <- pokeWord8 0xfd p0+                p2 <- pokeWord8 (fromIntegral nBytes) p1+                F.copyBytes (F.castPtr p2) pStr nBytes+                return (F.plusPtr p2 nBytes)++            else if nBytes <= 65535 then+             do p1 <- pokeWord8  0xfe p0+                p2 <- pokeWord16 (fromIntegral nBytes) p1+                F.copyBytes (F.castPtr p2) pStr nBytes+                return (F.plusPtr p2 nBytes)++            -- The Haskell Int type is only guaranteed to have at least 29+            -- bits of precision. We just limit the string size to 2^28,+            -- as 256MB should be enough for any sort of program text.+            else if nBytes <= 2^(28 :: Int) then+             do p1 <- pokeWord8  0xff p0+                p2 <- pokeWord32 (fromIntegral nBytes) p1+                F.copyBytes (F.castPtr p2) pStr nBytes+                return (F.plusPtr p2 nBytes)++            else error "shimmer.pokeText: text string too large."+{-# NOINLINE pokeText #-}+++---------------------------------------------------------------------------------------------------+-- | Poke a `Word8` into memory.+pokeWord8 :: Poke Word8+pokeWord8 w p+ = do   F.poke p w+        return (F.plusPtr p 1)+{-# INLINE pokeWord8 #-}+++-- | Poke a `Word16` into memory, in network byte order.+pokeWord16 :: Poke Word16+pokeWord16 w p+ = do   poke16 p 0 (toBE16 w)+        return (F.plusPtr p 2)+{-# INLINE pokeWord16 #-}+++-- | Poke a `Word32` into memory, in network byte order.+pokeWord32 :: Poke Word32+pokeWord32 w p+ = do   poke32 p 0 (toBE32 w)+        return (F.plusPtr p 4)+{-# INLINE pokeWord32 #-}+++-- | Poke a `Word64` into memory, in network byte order.+pokeWord64 :: Poke Word64+pokeWord64 w p+ = do   poke64 p 0 (toBE64 w)+        return (F.plusPtr p 8)+{-# INLINE pokeWord64 #-}+++-- | Poke a `Float32` into memory, in network byte order.+pokeFloat32 :: Poke Float+pokeFloat32 f p+ = F.allocaBytes 4 $ \p'+ -> do  F.poke (F.castPtr p' :: Ptr Float) f+        w32 <- F.peek (F.castPtr p' :: Ptr Word32)+        pokeWord32 w32 p+{-# INLINE pokeFloat32 #-}+++-- | Poke a `Float64` into memory, in network byte order.+pokeFloat64 :: Poke Double+pokeFloat64 f p+ = F.allocaBytes 8 $ \p'+ -> do  F.poke (F.castPtr p' :: Ptr Double) f+        w64 <- F.peek (F.castPtr p' :: Ptr Word64)+        pokeWord64 w64 p+{-# INLINE pokeFloat64 #-}+++from16 :: Word16 -> Word8+from16 = fromIntegral+{-# INLINE from16 #-}+++from32 :: Word32 -> Word8+from32 = fromIntegral+{-# INLINE from32 #-}+++from64 :: Word64 -> Word8+from64 = fromIntegral+{-# INLINE from64 #-}+++poke8 :: Ptr a -> Int -> Word8 -> IO ()+poke8 p i w = F.pokeByteOff p i w+{-# INLINE poke8 #-}+++poke16 :: Ptr a -> Int -> Word16 -> IO ()+poke16 p i w = F.pokeByteOff p i w+{-# INLINE poke16 #-}+++poke32 :: Ptr a -> Int -> Word32 -> IO ()+poke32 p i w = F.pokeByteOff p i w+{-# INLINE poke32 #-}+++poke64 :: Ptr a -> Int -> Word64 -> IO ()+poke64 p i w = F.pokeByteOff p i w+{-# INLINE poke64 #-}+
+ SMR/Core/Codec/Size.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE FlexibleInstances #-}+module SMR.Core.Codec.Size+        ( sizeOfFileDecls+        , sizeOfDecl+        , sizeOfExp+        , sizeOfRef)+where+import SMR.Core.Exp+import SMR.Prim.Op.Base+import qualified Data.Text              as T+import qualified Data.Text.Foreign      as T+++---------------------------------------------------------------------------------------------------+-- | Compute the serialized size of a shimmer file containing the given decls.+sizeOfFileDecls :: [Decl Text Prim] -> Int+sizeOfFileDecls decls+ = 4 + sizeOfList sizeOfDecl decls+++-- | Compute the serialized size of a given declaration.+sizeOfDecl :: Decl Text Prim -> Int+sizeOfDecl dd+ = case dd of+        DeclMac n x     -> 1 + sizeOfName n + sizeOfExp x+        DeclSet n x     -> 1 + sizeOfName n + sizeOfExp x+++---------------------------------------------------------------------------------------------------+-- | Compute the serialized size of the given expression.+sizeOfExp :: Exp Text Prim -> Int+sizeOfExp xx+ = case xx of+        XRef ref+         -> sizeOfRef ref++        XKey _key x+         -> 2 + sizeOfExp x++        XApp x1 xs+         | length xs <= 15+         -> 1 + sizeOfExp x1 + (sum $ map sizeOfExp xs)++         | otherwise+         -> 1 + sizeOfExp x1 + sizeOfList sizeOfExp xs++        XVar n b+         |  T.lengthWord16 n <= 15, b == 0+         -> 1 + T.lengthWord16 n++         |  otherwise+         -> 1 + sizeOfName n + sizeOfBump b++        XAbs ps x+         | length ps <= 15+         -> 1 + (sum $ map sizeOfParam ps) + sizeOfExp x++         | otherwise+         -> 1 + sizeOfList sizeOfParam ps + sizeOfExp x++        XSub cs x+         -> 1 + sizeOfList sizeOfCar cs   + sizeOfExp x+++-- | Compute the serialized size of a parameter.+sizeOfParam :: Param -> Int+sizeOfParam (PParam n _form)+ = 1 + sizeOfName n+++-- | Compute the serialized size of a substitution car.+sizeOfCar :: Car Text Prim -> Int+sizeOfCar cc+ = case cc of+        CSim (SSnv snv) -> 1 + sizeOfList sizeOfSnvBind snv+        CRec (SSnv snv) -> 1 + sizeOfList sizeOfSnvBind snv+        CUps (UUps ups) -> 1 + sizeOfList sizeOfUpsBump ups+++-- | Compute the serialized size of a substitution bind.+sizeOfSnvBind :: SnvBind Text Prim -> Int+sizeOfSnvBind sb+ = case sb of+        BindVar n i x   -> 1 + sizeOfName n + sizeOfBump i + sizeOfExp x+        BindNom i x     -> 1 + sizeOfNom i  + sizeOfExp x+++-- | Compute the serialized size of an lifting bump.+sizeOfUpsBump :: UpsBump -> Int+sizeOfUpsBump ub+ = case ub of+        ((n, d), i)     -> 1 + sizeOfName n + sizeOfBump d + sizeOfBump i+++---------------------------------------------------------------------------------------------------+-- | Compute the serialized size of the given reference.+sizeOfRef :: Ref Text Prim -> Int+sizeOfRef rr+ = case rr of+        RSym n          -> sizeOfName n+        RPrm p          -> 1 + sizeOfPrim p+        RTxt t          -> 1 + sizeOfName t+        RMac n          -> 1 + sizeOfName n+        RSet n          -> 1 + sizeOfName n+        RNom n          -> 1 + sizeOfNom  n+++sizeOfPrim :: Prim -> Int+sizeOfPrim pp+ = case pp of+        PrimTagUnit      -> 1+        PrimTagList      -> 1+        PrimLitBool   _  -> 1++        PrimLitWord8  _  -> 2+        PrimLitWord16 _  -> 3+        PrimLitWord32 _  -> 5+        PrimLitWord64 _  -> 9++        PrimLitInt8   _  -> 2+        PrimLitInt16  _  -> 3+        PrimLitInt32  _  -> 5+        PrimLitInt64  _  -> 9++        PrimLitFloat32 _ -> 5+        PrimLitFloat64 _ -> 9+        PrimOp tx        -> 1 + sizeOfName tx++        PrimLitNat _     -> 1 + sizeOfName (T.pack "nat") + 1 + 8+        PrimLitInt _     -> 1 + sizeOfName (T.pack "int") + 1 + 8+++---------------------------------------------------------------------------------------------------+-- | Compute the serialized size of a text string.+sizeOfName :: Text -> Int+sizeOfName tt+ = result+ where  n       = T.lengthWord16 tt+        result+         | n <  13           = 1 + n+         | n < 2^(8  :: Int) = 1 + 1 + n+         | n < 2^(16 :: Int) = 1 + 2 + n+         | n < 2^(32 :: Int) = 1 + 4 + n+         | otherwise         = error "shimmer.sizeOfName: name too long to serialize."+++-- | Compute the serialized size of a bump bounter.+sizeOfBump :: Integer -> Int+sizeOfBump _ = 2+++-- | Compute the serialized size of a nominal atom.+sizeOfNom  :: Integer -> Int+sizeOfNom _  = 4+++-- | Compute the serialized size of a sequence of things.+sizeOfList :: (a -> Int) -> [a] -> Int+sizeOfList fs xs+ = result+ where  n       = length xs+        result+         | n < 13            = 1 + sum (map fs xs)+         | n < 2^(8  :: Int) = 1 + 1 + sum (map fs xs)+         | n < 2^(16 :: Int) = 1 + 2 + sum (map fs xs)+         | n < 2^(32 :: Int) = 1 + 4 + sum (map fs xs)+         | otherwise         = error "shimmer.sizeOfList: sequence too long to serialize."+
+ SMR/Core/Codec/Word.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+module SMR.Core.Codec.Word+        ( fromBE64, fromLE64+        , fromBE32, fromLE32+        , fromBE16, fromLE16++        , toBE64,    toLE64+        , toBE32,    toLE32+        , toBE16,    toLE16)+where+import Data.Word        as Word+#include "MachDeps.h"++data Endian+        = Big | Little+        deriving Eq++-- | Get the endianness from the GHC header file.+--   We do this via a filty #include so that the information+--   is statically visible to the GHC simplifier.+systemEndian :: Endian+#ifdef WORDS_BIGENDIAN+systemEndian = Big+#else+systemEndian = Little+#endif+++-- | Convert from a big endian 64 bit value to the cpu endianness.+fromBE64 :: Word64 -> Word64+fromBE64 = if systemEndian == Big then id else Word.byteSwap64+{-# INLINE fromBE64 #-}++-- | Convert from a little endian 64 bit value to the cpu endianness.+fromLE64 :: Word64 -> Word64+fromLE64 = if systemEndian == Little then id else Word.byteSwap64+{-# INLINE fromLE64 #-}+++-- | Convert from a big endian 32 bit value to the cpu endianness.+fromBE32 :: Word32 -> Word32+fromBE32 = if systemEndian == Big then id else Word.byteSwap32+{-# INLINE fromBE32 #-}++-- | Convert from a little endian 32 bit value to the cpu endianness.+fromLE32 :: Word32 -> Word32+fromLE32 = if systemEndian == Little then id else Word.byteSwap32+{-# INLINE fromLE32 #-}+++-- | Convert from a big endian 16 bit value to the cpu endianness.+fromBE16 :: Word16 -> Word16+fromBE16 = if systemEndian == Big then id else Word.byteSwap16+{-# INLINE fromBE16 #-}++-- | Convert from a little endian 16 bit value to the cpu endianness.+fromLE16 :: Word16 -> Word16+fromLE16 = if systemEndian == Little then id else Word.byteSwap16+{-# INLINE fromLE16 #-}+++-- | Convert a 64 bit value in cpu endianess to big endian+toBE64 :: Word64 -> Word64+toBE64 = fromBE64+{-# INLINE toBE64 #-}++-- | Convert a 64 bit value in cpu endianess to little endian+toLE64 :: Word64 -> Word64+toLE64 = fromLE64+{-# INLINE toLE64 #-}+++-- | Convert a 32 bit value in cpu endianess to big endian+toBE32 :: Word32 -> Word32+toBE32 = fromBE32+{-# INLINE toBE32 #-}++-- | Convert a 32 bit value in cpu endianess to little endian+toLE32 :: Word32 -> Word32+toLE32 = fromLE32+{-# INLINE toLE32 #-}+++-- | Convert a 16 bit value in cpu endianness to big endian+toBE16 :: Word16 -> Word16+toBE16 = fromBE16+{-# INLINE toBE16 #-}++-- | Convert a 16 bit value in cpu endianness to little endian+toLE16 :: Word16 -> Word16+toLE16 = fromLE16+{-# INLINE toLE16 #-}++
+ SMR/Core/Exp.hs view
@@ -0,0 +1,38 @@++module SMR.Core.Exp+        ( -- * Abstract Syntax+          Decl  (..)+        , Exp   (..)+        , Param (..)+        , Form  (..)+        , Key   (..)+        , Train+        , Car   (..)+        , Snv   (..), SnvBind(..)+        , Ups   (..), UpsBump+        , Ref   (..)+        , Name, Nom, Depth, Bump+        , Text++         -- * Compounds+        , makeXApps, takeXApps+        , makeXAbs+        , nameOfParam, formOfParam++         -- * Substitution Trains+        , trainCons+        , trainAppend+        , trainApply+        , snvApply+        , snvOfNamesArgs++        -- * Substitution Pushing+        , pushHead+        , pushDeep)+where+import SMR.Core.Exp.Base+import SMR.Core.Exp.Compounds+import SMR.Core.Exp.Train+import SMR.Core.Exp.Push+import Data.Text                (Text)+
+ SMR/Core/Exp/Base.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE BangPatterns #-}+-- | The Shimmer Abstract Syntax Tree (AST)+module SMR.Core.Exp.Base where+import Data.Text                (Text)+++-- | Top-level declaration,+--   parameterised by the types of symbols and primitives.+data Decl s p+        = DeclMac Name (Exp s p)+        | DeclSet Name (Exp s p)+        deriving (Eq, Show)+++-- | Expression,+--   parameterised by the types of symbols and primitives+data Exp s p+        -- | Reference to an external thing.+        = XRef  !(Ref s p)++        -- | Keyed expressions.+        | XKey  !Key !(Exp s p)++        -- | Application of a function expression to an argument.+        | XApp  !(Exp s p) ![Exp s p]++        -- | Variable name with a depth counter.+        | XVar  !Name !Depth++        -- | Abstraction with a list of parameters and a body expression.+        | XAbs  ![Param] !(Exp s p)++        -- | Substitution train applied to an expression.+        --   The train car at the head of the list is applied first.+        | XSub  !(Train s p) !(Exp s p)+        deriving (Eq, Show)+++-- | Substitution train.+type Train s p+        = [Car s p]+++-- | Function parameter.+data Param+        = PParam !Name !Form+        deriving (Eq, Show)+++-- | Form of argument required in application.+data Form+        -- | Value for call-by-value.+        = PVal++        -- | Expression for call-by-name+        | PExp+        deriving (Eq, Show)+++-- | Expression keys (super primitives)+data Key+        -- | Delay evaluation of an expression used as the argument+        --   of a call-by-value function application.+        = KBox++        -- | Run a boxed expression.+        | KRun+        deriving (Eq, Show)+++-- | A car on the substitution train,+--   parameterised by the types used for symbols and primitives.+data Car s p+        -- | Simultaneous subsitution.+        = CSim  !(Snv s p)++        -- | Recursive substitution.+        | CRec  !(Snv s p)++        -- | Lifting.+        | CUps  !Ups+        deriving (Eq, Show)+++-- | Explicit substitution map,+--   parameterised by the types used for symbols and primitives.+data Snv s p+        = SSnv ![SnvBind s p]+        deriving (Eq, Show)++data SnvBind s p+        = BindVar !Name !Depth !(Exp s p)+        | BindNom !Nom         !(Exp s p)+        deriving (Eq, Show)+++-- | Lifting indicator,+--   mapping name and binding depth to number of levels to lift.+data Ups+        = UUps ![UpsBump]+        deriving (Eq, Show)+++-- | Indicates how to bump the index on a variable.+type UpsBump+        = ((Name, Depth), Bump)+++-- | Binding depth indicator.+type Depth = Integer+++-- | Bump index indicator.+type Bump  = Integer+++-- | A reference to some external thing.+data Ref s p+        -- | An uninterpreted symbol.+        = RSym  !s++        -- | A primitive value.+        | RPrm  !p++        -- | A text string.+        | RTxt  !Text++        -- | A macro name.+        | RMac  !Name++        -- | A set name.+        | RSet  !Name++        -- | A nominal variable.+        | RNom  !Nom+        deriving (Eq, Show)+++-- | Generic names for things.+type Name = Text+++-- | Index of a nominal constant.+type Nom = Integer+
+ SMR/Core/Exp/Compounds.hs view
@@ -0,0 +1,50 @@++module SMR.Core.Exp.Compounds where+import SMR.Core.Exp.Base+++-- Apps -----------------------------------------------------------------------+-- | Make an application of a function to the given list of arguments,+--   suppressing the application of there are no arguments.+makeXApps :: Exp s p -> [Exp s p] -> Exp s p+makeXApps xFun []       = xFun+makeXApps xFun xsArgs   = XApp xFun xsArgs+++-- | Take an application of a function to a list of arguments.+takeXApps :: Exp s p -> Maybe (Exp s p, [Exp s p])+takeXApps xx+ = case xx of+        XApp x1@(XApp _ _) x2+          -> case takeXApps x1 of+                -- TODO: Fix list append complexity.+                Just (f1, xs1) -> Just (f1, xs1 ++ x2)+                Nothing        -> Nothing++        XApp x1 x2+          -> Just (x1, x2)++        _ -> Nothing+++-- Abs ------------------------------------------------------------------------+-- | Make an abstraction,+--   short circuiting to the body if there are no parameters.+makeXAbs :: [Param] -> Exp s p -> Exp s p+makeXAbs [] xBody = xBody+makeXAbs ps xBody = XAbs ps xBody+++-- Param ----------------------------------------------------------------------+-- | Get the name of a function parameter.+nameOfParam :: Param -> Name+nameOfParam p+ = case p of+        PParam n  _     -> n+++-- | Get the argument form required by a parameter.+formOfParam :: Param -> Form+formOfParam p+ = case p of+        PParam _ f      -> f
+ SMR/Core/Exp/Push.hs view
@@ -0,0 +1,104 @@++module SMR.Core.Exp.Push where+import SMR.Core.Exp.Train+import SMR.Core.Exp.Compounds+import SMR.Core.Exp.Base+++-- | Push down any outermost substitution train to reveal the head constructor.+pushHead :: Exp s p -> Maybe (Exp s p)+pushHead xx+ = case xx of+        XRef _          -> Nothing+        XVar _ _        -> Nothing+        XAbs _ _        -> Nothing+        XApp _ _        -> Nothing+        XSub cs2 x2     -> pushTrain cs2 x2+        XKey _ _        -> Nothing+++-- | Push down the left-most substitution train in an expression,+--   or 'Nothing' if there isn't one.+pushDeep :: Exp s p -> Maybe (Exp s p)+pushDeep xx+ = case xx of+        XRef _          -> Nothing+        XVar _ _        -> Nothing++        XKey k1 x2+         | Just x2'     <- pushDeep x2+         -> Just $ XKey k1 x2'++         | otherwise    -> Nothing++        XApp x1 xs2+         |  Just x1'    <- pushDeep x1+         -> Just $ XApp x1' xs2++         |  Just xs2'   <- pushDeepFirst xs2+         -> Just $ XApp x1 xs2'++         |  otherwise   -> Nothing+++        XAbs ns x+         -> case pushDeep x of+                Nothing -> Nothing+                Just x' -> Just (XAbs ns x')++        XSub cs1 x2     -> pushTrain cs1 x2+++-- | Push down the first substiution train in the given list.+pushDeepFirst :: [Exp s p] -> Maybe [Exp s p]+pushDeepFirst [] = Nothing+pushDeepFirst (x : xs)+ = case pushDeep x of+        Nothing+         |  Just xs'    <- pushDeepFirst xs+         -> Just (x : xs')+         | otherwise    -> Nothing++        Just x'+         -> Just (x' : xs)+++-- | Push a substitution train down into an expression to reveal+--   the head constructor.+pushTrain :: [Car s p] -> Exp s p -> Maybe (Exp s p)+pushTrain cs1 x2+ = case x2 of+        -- Unfold macro under a substitution.+        -- Macro and symbol bodies are closed,+        -- so we can drop the substitution.+        XRef (RMac _)   -> Just x2+        XRef (RSym _)   -> Just x2+        XRef (RPrm _)   -> Just x2+        XRef (RNom _)   -> Just x2++        -- Reference to some other thing.+        XRef _          -> Nothing++        -- Apply the train to a variable.+        XVar name depth+         -> Just $ trainApplyVar cs1 name depth++        -- Push train under key.+        XKey k21 x22+         -> Just $ XKey k21 (trainApply cs1 x22)++        -- Push train into both sides of an application.+        XApp x21 x22+         -> Just $ XApp (trainApply cs1 x21) (map (trainApply cs1) x22)++        -- Push train under abstraction.+        XAbs ps21 x22+         -> let ns21    = map nameOfParam ps21+                cs1'    = trainBump ns21 cs1+            in  Just $ XAbs ps21 (trainApply cs1' x22)++        -- Combine trains.+        XSub cs2 x22+         -> Just $ trainApply (cs2 ++ cs1) x22++
+ SMR/Core/Exp/Train.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE ParallelListComp #-}+module SMR.Core.Exp.Train where+import SMR.Core.Exp.Base+import Data.Maybe+++-- Train ----------------------------------------------------------------------+-- | Cons a car on the front of an existing train.+--+--   If the new car is empty it will be suppressed.+--+--   If the new car can be combined with the first car on the existing+--   train then it will be combined.+--+trainCons :: Car s p -> [Car s p] -> [Car s p]+trainCons c1 cs2+ | carIsEmpty c1 = cs2+ | otherwise+ = case cs2 of+        []+         -> c1 : []++        c2 : cs2'+         |  CUps ups1   <- c1+         ,  CUps ups2   <- c2+         -> CUps (upsCombine ups1 ups2) : cs2'++         |  otherwise+         -> c1 : cs2+++-- | Append two trains.+trainAppend :: [Car s p] -> [Car s p] -> [Car s p]+trainAppend ccA ccB+ = case ccA of+        []        -> ccB+        cA : csA  -> trainAppend' cA csA ccB+ where+        trainAppend' c1 cs1 cc2+         = case cs1 of+                -- Combine the  state with the first car on the second train.+                []+                 -> trainCons c1 cc2++                -- Walk over the first train, combining ups's as we go.+                c1' : cs1'+                 |  CUps ups1  <- c1+                 ,  CUps ups1' <- c1'+                 -> trainAppend' (CUps (upsCombine ups1 ups1')) cs1' cc2++                 |  otherwise+                 -> c1 : (trainAppend' c1' cs1' cc2)+++-- | Bump a train due to pushing it under an abstraction with the+--   given parameter names.+trainBump :: [Name] -> [Car s p] -> [Car s p]+trainBump ns cs+ = case cs of+        []     -> []++        CSim snv : cs'+         -> trainCons (CSim (snvBump ns snv)) $ trainBump ns cs'++        CRec snv : cs'+         -> trainCons (CRec (snvBump ns snv)) $ trainBump ns cs'++        CUps ups : cs'+         -> trainCons (CUps (upsBump ns ups)) $ trainBump ns cs'+++-- | Wrap an expression in a substitution train.+--   If the expression is a plain+trainApply :: [Car s p] -> Exp s p -> Exp s p+trainApply cs1 xx+ | []  <- cs1+ = xx++ | otherwise+ = case xx of+        XRef (RMac _)   -> xx+        XRef (RSym _)   -> xx+        XRef (RPrm _)   -> xx+        XRef (RNom ix)  -> trainApplyNom cs1 ix+        XVar name depth -> trainApplyVar cs1 name depth+        XSub cs2  x2    -> trainApply (trainAppend cs2 cs1) x2+        _               -> XSub cs1 xx+++-- | Apply a train to a named variable of a given name and depth.+trainApplyVar :: [Car s p] -> Name -> Integer -> Exp s p+trainApplyVar cs name depth+ = case cs of+        []              -> XVar name depth+        CSim snv : cs'  -> trainApply cs' (snvApplyVar False snv name depth)+        CRec snv : cs'  -> trainApply cs' (snvApplyVar True  snv name depth)+        CUps ups : cs'  -> trainApply cs' (upsApplyVar ups name depth)+++-- | Apply a train to a nominal variable of a given index.+trainApplyNom :: [Car s p] -> Integer -> Exp s p+trainApplyNom cs ix+ = case cs of+        []              -> XRef (RNom ix)+        CSim snv  : cs' -> trainApply cs' (snvApplyNom  False snv ix)+        CRec snv  : cs' -> trainApply cs' (snvApplyNom  True  snv ix)+        CUps _ups : cs' -> trainApply cs' (XRef (RNom ix))+++-- Car ------------------------------------------------------------------------+-- | Check if a substitution car is empty.+carIsEmpty :: Car s p -> Bool+carIsEmpty c+ = case c of+        CSim snv -> snvIsEmpty snv+        CRec snv -> snvIsEmpty snv+        CUps ups -> upsIsEmpty ups+++-- Snv ------------------------------------------------------------------------+-- | Build a substitution from lists of names and arguments.+snvOfNamesArgs :: [Name] -> [Exp s p] -> Snv s p+snvOfNamesArgs ns xs+ = SSnv [BindVar n 0 x | n <- ns | x <- xs]+++-- | Check if the given substitution is empty.+snvIsEmpty :: Snv s p -> Bool+snvIsEmpty (SSnv bs)+ = case bs of+        []      -> True+        _       -> False+++-- | Bump a substitution due to pushing it under an abstraction with+--   the given parameter names.+snvBump :: [Name] -> Snv s p -> Snv s p+snvBump ns (SSnv ts)+ = SSnv $ mapMaybe (snvBump1 ns) ts+ where+        snvBump1 names (BindVar name depth x)+         = Just $ BindVar name+                (depth + (if elem name names then 1 else 0))+                (upsApply (UUps (map (\name' -> ((name', 0), 1)) names)) x)++        snvBump1 names (BindNom ix x)+         = Just $ BindNom ix+                (upsApply (UUps (map (\name' -> ((name', 0), 1)) names)) x)+++-- | Wrap a train consisting of a single simultaneous substitution+--   around an expression.+snvApply :: Bool -> Snv s p -> Exp s p -> Exp s p+snvApply isRec snv@(SSnv bs) xx+ = case bs of+        []        -> xx+        _ | isRec -> trainApply (CRec snv : []) xx+        _         -> trainApply (CSim snv : []) xx+++-- | Apply a substitution to a variable of a given name and depth.+snvApplyVar :: Bool -> Snv s p -> Name -> Integer -> Exp s p+snvApplyVar isRec snv@(SSnv bs) name depth+ = case bs of+        []+         -> XVar name depth++        BindVar name' depth' x' : bs'+         |  name  == name'+         ,  depth == depth'+         -> if isRec then XSub (CRec snv : []) x'+                     else x'++         |  name   == name'+         ,  depth  >  depth'+         -> XVar name (depth - 1)++         |  otherwise+         -> snvApplyVar isRec (SSnv bs') name depth++        BindNom{} : bs'+         -> snvApplyVar isRec (SSnv bs') name depth+++-- | Apply a substitution to a nominal variable of the given index.+snvApplyNom :: Bool -> Snv s p -> Integer -> Exp s p+snvApplyNom isRec snv@(SSnv bs) ix+ = case bs of+        []+         -> XRef (RNom ix)++        BindVar{} : bs'+         -> snvApplyNom isRec (SSnv bs') ix++        BindNom ix' x' : bs'+         |  ix == ix'+         -> if isRec then XSub (CRec snv : []) x'+                     else x'++         | otherwise+         -> snvApplyNom isRec (SSnv bs') ix+++-- Ups ------------------------------------------------------------------------+-- | Check if the given ups is empty.+upsIsEmpty :: Ups -> Bool+upsIsEmpty (UUps bs)+ = case bs of+        []      -> True+        _       -> False+++-- | Wrap an expression in a train consisting of a single ups.+upsApply :: Ups -> Exp s p -> Exp s p+upsApply ups@(UUps us) xx+ = case us of+        []      -> xx+        _       -> trainApply ((CUps ups) : []) xx+++-- | Apply an ups to a variable.+upsApplyVar :: Ups -> Name -> Integer -> Exp s n+upsApplyVar (UUps bs) name ix+ = case bs of+        []+         -> XVar name ix++        ((name', depth'), inc') : bs'+         |  name   == name'+         ,  depth' <= ix+         -> upsApplyVar (UUps bs') name (ix + inc')++         |  otherwise+         -> upsApplyVar (UUps bs') name ix+++-- | Bump ups (substitution lifting) due to pushing it+--   under an absraction with the given named binders.+upsBump :: [Name] -> Ups -> Ups+upsBump ns0 (UUps bs)+ = UUps $ mapMaybe (upsBump1 ns0) bs+ where+        upsBump1 ns l+         | ((n, d), inc) <- l+         , elem n ns+         = Just ((n, d + 1), inc)++         | otherwise+         = Just l+++-- | Combine two lists of ups.+upsCombine :: Ups -> Ups -> Ups+upsCombine (UUps ts1) (UUps ts2)+ = UUps (foldr upsCombineBump ts2 ts1)+++-- | Combine a bump with an existing list of them.+--   Applying the result to an expression will achieve the same result as+--   applying the whole list and then the extra one.+upsCombineBump :: UpsBump -> [UpsBump] -> [UpsBump]+upsCombineBump b bs+ | ((name, depth), inc) <- b+ = case bs of+        -- We cannot combine the new bump with anything else,+        -- so add it to the end of the list.+        []+         -> [b]++        b'@((name', depth'), inc') : bs'+         -- Combine the new bump with an existing one of the same name.+         |  name  == name'+         ,  depth == depth'+         -> ((name, depth'), inc + inc') : bs'++         -- Try to combine the new bump with the tail of the list.+         |  otherwise+         -> b' : (upsCombineBump b bs')+
+ SMR/Core/Step.hs view
@@ -0,0 +1,351 @@+{-# LANGUAGE BangPatterns #-}+module SMR.Core.Step+        ( Config        (..)+        , World         (..)+        , Result        (..)+        , newWorld+        , steps+        , step)+where+import SMR.Core.Exp+import SMR.Core.World+import SMR.Prim.Op.Base+import Data.Text                (Text)+import Data.Map                 (Map)+import qualified Data.Map       as Map+++--------------------------------------------------------------------------------+-- | Evaluation config+data Config s p w+        = Config+        { -- | Reduce under lambda abstractions.+          configUnderLambdas    :: !Bool++          -- | Reduce arguments when head is not an abstraction.+        , configHeadArgs        :: !Bool++          -- | Primitive operator declarations.+        , configPrims           :: !(Map p (PrimEval s p w))++          -- | Macro declarations.+        , configDeclsMac        :: !(Map Name (Exp s p)) }+++-- | Result of evaluation.+data Result+        = ResultDone+        | ResultError   Text+        deriving Show+++-------------------------------------------------------------------------------+-- | Multi-step reduction to normal form.+steps   :: (Ord p, Show p)+        => Config s p w+        -> World w -> Exp s p+        -> IO (Either Text (Exp s p))++steps !config !world !xx+ = do   erx <- step config world xx+        case erx of+         Left ResultDone         -> return $ Right xx+         Left (ResultError err)  -> return $ Left err+         Right xx'               -> steps config world xx'+++-------------------------------------------------------------------------------+-- | Single step reduction.+--+--   This is a definitional interpreter, intended to be easy to understand+--   and get right, but not fast. Each time we take a step we decend into+--   the AST looking for the next redex, which causes evaluation to have+--   a higher asymptotic complexity than it would with an evaluator that+--   that manages the evaluation context properly.+--+step    :: (Ord p, Show p)+        => Config s p w+        -> World w -> Exp s p+        -> IO (Either Result (Exp s p))++step !config !world !xx+ = case xx of+        -- Reference+        XRef ref+         -> case ref of+                -- Expand macro declarations.+                RMac n+                  -> case Map.lookup n (configDeclsMac config) of+                        Nothing -> return $ Left ResultDone+                        Just x  -> return $ Right x++                -- Leave other references as-is.+                _ -> return $ Left ResultDone++        -- Plain variable, we're done.+        XVar{}+         -> return $ Left ResultDone++        -- Abstraction.+        XAbs ns1 x2+         -- Reduce the body of the abstraction if requested.+         |  configUnderLambdas config+         -> do  er2'     <- step config world x2+                case er2' of+                 Left  r2  -> return $ Left r2+                 Right x2' -> return $ Right $ XAbs ns1 x2'++         -- Otherwise treat abstractions as values.+         |  otherwise+         -> return $ Left ResultDone++        -- Application.+        XApp xF []+         -> return $ Right xF++        XApp{}+         -- Unzip the application and try to step the functional expression first.+         |  Just (xF, xsArgs)    <- takeXApps xx+         -> do  erx <- step (config { configUnderLambdas = False })+                            world xF+                case erx of+                 -- Functional expression makes progress.+                 Right xF'+                  -> return $ Right $ makeXApps xF' xsArgs++                 -- Evaluation of functional expression failed.+                 Left err@(ResultError _)+                  -> return $ Left err++                 -- Functional expression is done.+                 Left ResultDone+                  -> case xF of+                      XRef (RPrm primF)  -> stepAppPrm config world primF xsArgs+                      XAbs nsParam xBody -> stepAppAbs config world nsParam xBody xsArgs++                      -- Functional expression is inactive, but optionally+                      -- continue reducing arguments to eliminate all of+                      -- the redexes in the expression.+                      _ |  configHeadArgs config+                        -> do   erxArgs <- stepFirstVal config world xsArgs+                                case erxArgs of+                                 Right xsArgs' -> return $ Right $ makeXApps xF xsArgs'+                                 Left res      -> return $ Left res++                        |  otherwise+                        -> return $ Left ResultDone++         | otherwise+         -> return $ Left ResultDone++        -- Substitution trains.+        XSub{}+         -> case pushHead xx of+                Nothing  -> return $ Left ResultDone+                Just xx' -> return $ Right xx'++        -- Boxed expressions are already normal forms.+        XKey KBox _+         -> return $ Left ResultDone++        -- Run a boxed expression.+        XKey KRun x1+         -> do  erx <- step (config { configUnderLambdas = False+                                    , configHeadArgs     = False })+                            world x1++                case erx of+                 -- Body makes progress.+                 Right x1'+                  -> return $ Right (XKey KRun x1')++                 -- Body expression evaluation failed.+                 Left err@(ResultError _)+                  -> return $ Left err++                 -- If the body expression is a box then unwrap it,+                 -- otherwise just return the value as-is.+                 Left ResultDone+                  -> case x1 of+                         XKey KBox x11   -> return $ Right x11+                         _               -> return $ Right x1+++-------------------------------------------------------------------------------+-- | Step an application of a primitive operators to its arguments.+stepAppPrm+        :: (Ord p, Show p)+        => Config s p w+        -> World w -> p -> [Exp s p]+        -> IO (Either Result (Exp s p))++stepAppPrm !config !world !prim !xsArgs+ = case Map.lookup prim (configPrims config) of+        Nothing         -> return $ Left ResultDone+        Just primEval   -> stepPrim config world primEval xsArgs+++-------------------------------------------------------------------------------+-- | Step an application of an abstraction applied to its arguments.+stepAppAbs+        :: (Ord p, Show p)+        => Config s p w+        -> World w -> [Param] -> Exp s p -> [Exp s p]+        -> IO (Either Result (Exp s p))++stepAppAbs !config !world !psParam !xBody !xsArgs+ = do+        let arity         = length psParam+        let args          = length xsArgs+        let xsArgs_sat    = take arity xsArgs+        let xsArgs_remain = drop arity xsArgs+        let fsParam_sat   = map formOfParam psParam++        erxs   <- stepFirst config world xsArgs_sat fsParam_sat+        case erxs of+         -- One of the args makes progress.+         Right xsArgs_sat'+          -> do let xFun    = XAbs psParam xBody+                return $ Right+                 $ makeXApps (makeXApps xFun xsArgs_sat') xsArgs_remain++         -- Stepping one of the arguments failed.+         Left err@(ResultError _)+          ->    return $ Left err++         -- The arguments are all done.+         Left ResultDone+          -- Saturated application+          | args == arity+          -> do let nsParam = map nameOfParam psParam+                let snv     = snvOfNamesArgs nsParam xsArgs+                return $ Right+                 $ snvApply False snv xBody++          -- Under application.+          | args < arity+          -> do let psParam_sat    = take args psParam+                let nsParam_sat    = map nameOfParam psParam_sat+                let psParam_remain = drop args psParam+                let snv     = snvOfNamesArgs nsParam_sat xsArgs_sat+                return $ Right+                 $ makeXApps+                        (snvApply False snv $ XAbs psParam_remain xBody)+                        xsArgs_remain++          -- Over application.+          | otherwise+          -> do let nsParam = map nameOfParam psParam+                let snv     = snvOfNamesArgs nsParam xsArgs_sat+                return $ Right+                 $ makeXApps+                        (snvApply False snv xBody)+                        xsArgs_remain+++-------------------------------------------------------------------------------+-- | Step an application of a primitive operator to some arguments.+stepPrim+        :: (Ord p, Show p)+        => Config s p w+        -> World w -> PrimEval s p w -> [Exp s p]+        -> IO (Either Result (Exp s p))++stepPrim !config !world !pe !xsArgs+ | PrimEval _prim _desc csArg eval <- pe+ = let+        -- Evaluation of arguments is complete.+        evalArgs [] [] xsArgsDone+         = do   mr <- eval world (reverse xsArgsDone)+                case mr of+                 Just xResult    -> return $ Right xResult+                 Nothing         -> return $ Left ResultDone++        -- We have more args than the primitive will accept.+        evalArgs [] xsArgsRemain xsArgsDone+         = do   mr <- eval world (reverse xsArgsDone)+                case mr of+                 Just xResult    -> return $ Right $ makeXApps xResult xsArgsRemain+                 Nothing         -> return $ Left ResultDone++        -- Evaluate the next argument if needed.+        evalArgs (cArg' : csArg') (xArg' : xsArg') xsArgsDone+         -- Primitive does not demand a value fo rthis arg.+         | PExp <- cArg'+         = evalArgs csArg' xsArg' (xArg' : xsArgsDone)++         -- Primtiive demands a value for this arg.+         | otherwise+         = do   erxArg' <-  step (config { configUnderLambdas = False+                                         , configHeadArgs = False })+                                 world xArg'+                case erxArg' of+                 Left err@(ResultError _)+                  -> return $ Left err++                 Left ResultDone+                  -> evalArgs csArg' xsArg' (xArg' : xsArgsDone)++                 Right xArg''+                  -> return $ Right+                        $ makeXApps (XRef (RPrm (primEvalName pe)))+                         $ (reverse xsArgsDone) ++ (xArg'' : xsArg')++        -- We have less args than the prim will accept,+        -- so leave the application as it is.+        evalArgs _ [] _xsArgsDone+         = return $ Left ResultDone++   in   evalArgs csArg xsArgs []+++-------------------------------------------------------------------------------+-- | Step the first available expression in a list,+--   reducing them all towards values.+stepFirstVal+        :: (Ord p, Show p)+        => Config s p w+        -> World w -> [Exp s p]+        -> IO (Either Result [Exp s p])++stepFirstVal !config !world !xx+ = stepFirst config world xx (replicate (length xx) PVal)+++-- | Step the first available expression in a list.+stepFirst+        :: (Ord p, Show p)+        => Config s p w+        -> World w -> [Exp s p] -> [Form]+        -> IO (Either Result [Exp s p])++stepFirst !config !world !xx !ff+ = case (xx, ff) of+        ([], _)+         -> return $ Left ResultDone++        (_,  [])+         -> return $ Left ResultDone++        (x1 : xs2, f1 : fs2)+         | PExp <- f1+         -> do  erx <- stepFirst config world xs2 fs2+                case erx of+                 Left r     -> return $ Left r+                 Right xs2' -> return $ Right $ x1 : xs2'++         | otherwise+         -> do  erx1 <- step config world x1+                case erx1 of+                 Left err@(ResultError{})+                  -> return $ Left err++                 Left ResultDone+                  -> do erxs2 <- stepFirst config world xs2 fs2+                        case erxs2 of+                         Left  r    -> return $ Left r+                         Right xs2' -> return $ Right $ x1 : xs2'++                 Right x1'+                  -> return $ Right $ x1' : xs2+
+ SMR/Core/World.hs view
@@ -0,0 +1,22 @@++module SMR.Core.World where+import Data.IORef+++-- | World state for evaluation+data World w+        = World+        { -- | Generator for nominal variables.+          worldNomGen   :: !(IORef Integer)++          -- | User state+        , worldUser     :: w }+++-- | Initialize a new world.+newWorld :: w -> IO (World w)+newWorld w+ = do   refNomGen       <- newIORef 0+        return  $ World+                { worldNomGen   = refNomGen+                , worldUser     = w }
+ SMR/Data/Bag.hs view
@@ -0,0 +1,64 @@++module SMR.Data.Bag where+import Prelude hiding (map)+import qualified Data.List as List+++-- | An unordered collection of things.+--   O(1) to add a single element, a list of elements, or union two bags.+data Bag a+        = BagNil+        | BagElem  a+        | BagList  [a]+        | BagUnion (Bag a) (Bag a)+        deriving Show+++-- | O(1). Construct an empty bag.+nil     :: Bag a+nil = BagNil+++-- | O(1). Construct a bag containing a single element.+singleton :: a -> Bag a+singleton x+ = BagElem x+++-- | O(1). Construct a bag containing a list of elements.+list :: [a] -> Bag a+list xs+ = BagList xs+++-- | O(1). Union two bags.+union :: Bag a -> Bag a -> Bag a+union xs1 xs2+ = BagUnion xs1 xs2+++-- | O(n). Convert a bag to a list.+--   The elements come out in some deterministic but arbitrary order, no promises.+toList :: Bag a -> [a]+toList bag+ = go [] bag+ where+        go xs1  BagNil          = xs1+        go xs1 (BagElem x)      = x : xs1+        go xs1 (BagList xs2)    = go_list xs1 xs2+        go xs1 (BagUnion b1 b2) = go (go xs1 b1) b2++        go_list _   []          = []+        go_list xs1 (x : xs2)   = go_list (x : xs1) xs2+++-- | Apply a function to all the elements in a bag.+map :: (a -> b) -> Bag a -> Bag b+map f bag+ = case bag of+        BagNil          -> BagNil+        BagElem  x      -> BagElem  (f x)+        BagList  xs     -> BagList  (List.map f xs)+        BagUnion b1 b2  -> BagUnion (map f b1) (map f b2)++
+ SMR/Data/Located.hs view
@@ -0,0 +1,39 @@++module SMR.Data.Located where+++-- | Location in a source file.+data Location+        = L  Int Int+        deriving Show+++-- | A thing located at the given range in a source file.+data Located a+        = LL Location Location a+        deriving Show+++-- | Take the start point of a located thing.+startOfLocated :: Located a -> Location+startOfLocated (LL start _ _) = start+++-- | Take the end point of a located thing.+endOfLocated :: Located a -> Location+endOfLocated (LL _ end _) = end+++-- | Take the value of a located thing.+valueOfLocated :: Located a -> a+valueOfLocated (LL _ _ x) = x++-- | Increment the character position of a located thing.+incCharOfLocation :: Int -> Location -> Location+incCharOfLocation n (L l c) = L l (c + n)+++-- | Increment the line position of a located thing.+incLineOfLocation :: Int -> Location -> Location+incLineOfLocation n (L l _) = L (l + n) 1+
+ SMR/Prim/Name.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+module SMR.Prim.Name+        ( Prim (..)++        -- * Pretty+        , pprPrim+        , readPrim++        -- * Bool+        , makeXBool, takeXBool, takeArgBool++        -- * Nat+        , makeXNat,  takeXNat,  takeArgNat++        -- * List+        , makeXList)+where+import SMR.Prim.Op.Base+import Data.Text                (Text)+import Data.Set                 (Set)+import qualified Data.Set       as Set+import qualified Data.Char      as Char+import qualified Data.Text      as Text+import Numeric+++-- | Pretty print a primitive operator.+pprPrim :: Prim -> Text+pprPrim pp+ = case pp of+        PrimTagUnit        -> "unit"+        PrimTagList        -> "list"++        PrimLitBool True   -> "true"+        PrimLitBool False  -> "false"++        PrimLitNat n       -> Text.pack $ "nat'" ++ show n+        PrimLitInt i       -> Text.pack $ "int'" ++ show i++        PrimLitWord8  w    -> Text.pack $ "w8'"  ++ showHex w ""+        PrimLitWord16 w    -> Text.pack $ "w16'" ++ showHex w ""+        PrimLitWord32 w    -> Text.pack $ "w32'" ++ showHex w ""+        PrimLitWord64 w    -> Text.pack $ "w64'" ++ showHex w ""++        PrimLitInt8   i    -> Text.pack $ "i8'"  ++ show i+        PrimLitInt16  i    -> Text.pack $ "i16'" ++ show i+        PrimLitInt32  i    -> Text.pack $ "i32'" ++ show i+        PrimLitInt64  i    -> Text.pack $ "i64'" ++ show i++        PrimLitFloat32 f   -> Text.pack $ "f32'" ++ show f+        PrimLitFloat64 f   -> Text.pack $ "f64'" ++ show f++        PrimOp op          -> op+++-- | Parse a primitive name, without the leading '#'.+readPrim :: Set Text -> Text -> Maybe Prim+readPrim ps tx+ -- Literal Booleans.+ | tx == "true"         = Just $ PrimLitBool True+ | tx == "false"        = Just $ PrimLitBool False++ -- Literal Nats.+ | Text.isPrefixOf "nat'" tx+ , tx'  <- Text.unpack $ Text.drop 4 tx+ , all Char.isDigit tx'+ , not $ null tx'+ = Just $ PrimLitNat (read tx')++ -- Other primtiives.+ | Set.member tx ps+ = Just $ PrimOp tx++ | tx == "unit" = Just PrimTagUnit+ | tx == "list" = Just PrimTagList++ -- Unrecognised.+ | otherwise+ = Nothing
+ SMR/Prim/Op.hs view
@@ -0,0 +1,40 @@+module SMR.Prim.Op+        ( primNames+        , primOps+        , primOpsBool+        , primOpsList+        , primOpsMatch+        , primOpsNat+        , primOpsNom+        , primOpsSym)+where+import SMR.Prim.Op.Base+import SMR.Prim.Op.Bool+import SMR.Prim.Op.Nat+import SMR.Prim.Op.Sym+import SMR.Prim.Op.Nom+import SMR.Prim.Op.List+import SMR.Prim.Op.Match+import Data.Text                (Text)+import Data.Set                 (Set)+import qualified Data.Set       as Set+++-- | Set containing textual names of all the primitive operators.+primNames :: Set Text+primNames+ = Set.fromList [ n | PrimOp n <- map primEvalName $ primOps ]+++-- | Evaluators for all the primitive operators.+primOps :: [PrimEval Text Prim w]+primOps+ = concat+        [ primOpsBool+        , primOpsNat+        , primOpsList+        , primOpsSym+        , primOpsNom+        , primOpsMatch ]++
+ SMR/Prim/Op/Base.hs view
@@ -0,0 +1,130 @@++module SMR.Prim.Op.Base+        ( Prim          (..)+        , PrimEval      (..)++          -- * Exp+        , takeArgExp++          -- * Bool+        , makeXBool, takeXBool, takeArgBool++          -- * Nat+        , makeXNat, takeXNat,  takeArgNat++          -- * List+        , makeXList)+where+import SMR.Core.Exp+import SMR.Core.World+import Data.Text        (Text)+import Data.Int+import Data.Word++-------------------------------------------------------------------------------+-- | Primitive values and operators.+data Prim+        = PrimTagUnit+        | PrimTagList++        | PrimLitBool           Bool+        | PrimLitNat            Integer+        | PrimLitInt            Integer++        | PrimLitWord8          Word8+        | PrimLitWord16         Word16+        | PrimLitWord32         Word32+        | PrimLitWord64         Word64++        | PrimLitInt8           Int8+        | PrimLitInt16          Int16+        | PrimLitInt32          Int32+        | PrimLitInt64          Int64++        | PrimLitFloat32        Float+        | PrimLitFloat64        Double++        | PrimOp                Text+        deriving (Eq, Ord, Show)+++-- Exp ----------------------------------------------------+-- | Take the first expression argument from a list of primitives.+takeArgExp+        :: [Exp s Prim]+        -> Maybe (Exp s Prim, [Exp s Prim])+takeArgExp xx+ = case xx of+        x1 : xs -> Just (x1, xs)+        _       -> Nothing+++-- Bool ---------------------------------------------------+-- | Take a literal Bool from an expression.+takeXBool :: Exp s Prim -> Maybe Bool+takeXBool xx+ = case xx of+        XRef (RPrm (PrimLitBool b))     -> Just b+        _                               -> Nothing+++-- | Make a literal Bool expression.+makeXBool :: Bool -> Exp s Prim+makeXBool b+ = XRef (RPrm (PrimLitBool b))+++-- | Split a literal Bool from an argument list.+takeArgBool :: [Exp s Prim] -> Maybe (Bool, [Exp s Prim])+takeArgBool xx+ = case xx of+        XRef (RPrm (PrimLitBool b)) : xs+          -> Just (b, xs)+        _ -> Nothing+++-- Nat ----------------------------------------------------+-- | Take a literal Nat from an expression.+takeXNat :: Exp s Prim -> Maybe Integer+takeXNat xx+ = case xx of+        XRef (RPrm (PrimLitNat n))      -> Just n+        _                               -> Nothing++-- | Make a literal Nat expression.+makeXNat :: Integer -> Exp s Prim+makeXNat n+ = XRef (RPrm (PrimLitNat n))+++-- | Split a literal Nat from an argument list.+takeArgNat :: [Exp s Prim] -> Maybe (Integer, [Exp s Prim])+takeArgNat xx+ = case xx of+        XRef (RPrm (PrimLitNat n)) : xs+          -> Just (n, xs)+        _ -> Nothing+++-- List ---------------------------------------------------+-- | Make a list of expressions.+makeXList :: [Exp s Prim] -> Exp s Prim+makeXList xs+ = XApp (XRef (RPrm PrimTagList)) xs+++-------------------------------------------------------------------------------+-- | Primitive evaluator.+data PrimEval s p w+        = PrimEval+        { primEvalName  :: p            -- ^ Op name.+        , primEvalDesc  :: Text         -- ^ Op description.+        , primEvalForm  :: [Form]       -- ^ Argument passing methods.++          -- | Evaluation function.+        , primEvalFun+                :: World w+                -> [Exp s p]+                -> IO (Maybe (Exp s p))+        }+
+ SMR/Prim/Op/Bool.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}+module SMR.Prim.Op.Bool where+import SMR.Core.Exp+import SMR.Prim.Op.Base+import Data.Text        (Text)+++-- | Primitive evaluators for boolean operators.+primOpsBool :: [PrimEval s Prim w]+primOpsBool+ = [ primOpBool1 "not" "boolean negation" (\b -> not b)+   , primOpBool2 "and" "boolean and"      (&&)+   , primOpBool2 "or"  "boolean or"       (||)+   , primOpIf ]+++-- | Construct an evaluator for 1-arity bool operator.+primOpBool1+        :: Name -> Text+        -> (Bool -> Bool)+        -> PrimEval s Prim w++primOpBool1 name desc fn+ = PrimEval (PrimOp name) desc [PVal] fn'+ where  fn' _world as0+         | Just (b1, []) <- takeArgBool as0+         = return $ Just $ makeXBool (fn b1)+        fn' _world _+         = return $ Nothing+++-- | Construct an evaluator for 2-arity bool operator.+primOpBool2+        :: Name -> Text+        -> (Bool -> Bool -> Bool)+        -> PrimEval s Prim w++primOpBool2 name desc fn+ = PrimEval (PrimOp name) desc [PVal, PVal] fn'+ where+        fn' _world as0+         | Just (b1, as1) <- takeArgBool as0+         , Just (b2, [])  <- takeArgBool as1+         = return $ Just $ makeXBool (fn b1 b2)+        fn' _world _+         = return $ Nothing+++-- | Primitive evaluator for the #if operator.+--   Only the scrutinee is demanded, while the branches are not.+primOpIf :: PrimEval s Prim w+primOpIf+ = PrimEval+        (PrimOp "if")+        "boolean if-then-else operator"+        [PVal, PExp, PExp] fn'+ where+        fn' _world as0+         | Just (b1, as1) <- takeArgBool as0+         , Just (x1, as2) <- takeArgExp  as1+         , Just (x2, [])  <- takeArgExp  as2+         = return $ Just $ if b1 then x1 else x2++        fn' _world _+         = return $ Nothing+
+ SMR/Prim/Op/List.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings #-}+module SMR.Prim.Op.List where+import SMR.Core.Exp+import SMR.Prim.Op.Base+++-- | Primitive evaluators for list operators.+primOpsList :: [PrimEval s Prim w]+primOpsList+ = [ primOpListCons,    primOpListUncons+   , primOpListSnoc,    primOpListUnsnoc+   , primOpListAppend ]+++-- | Cons an element to a the front of a list.+primOpListCons :: PrimEval s Prim w+primOpListCons+ = PrimEval+        (PrimOp "list-cons")+        "add an element to the front of a list"+        [PExp, PVal] fn'+ where+        fn' _world as0+         | Just (x1, as1) <- takeArgExp as0+         , Just (XApp tag@(XRef (RPrm PrimTagList)) xs, [])+                          <- takeArgExp as1+         = return $ Just $ XApp tag (x1 : xs)++        fn' _world _+         = return $ Nothing+++-- | Split an element from the front of a list.+primOpListUncons :: PrimEval s Prim w+primOpListUncons+ = PrimEval+        (PrimOp "list-uncons")+        "split an element from the front of a list"+        [PVal, PExp] fn'+ where+        fn' _world as0+         | Just (XApp tag@(XRef (RPrm PrimTagList)) xx, as1)+                          <- takeArgExp as0+         , Just (x2, [])  <- takeArgExp as1+         = case xx of+                x1 : xs -> return $ Just $ XApp x2 [x1, XApp tag xs]+                []      -> return $ Nothing+        fn' _world _+         = return $ Nothing+++-- | Snoc an element to a the end of a list.+primOpListSnoc :: PrimEval s Prim w+primOpListSnoc+ = PrimEval+        (PrimOp "list-snoc")+        "add an element to the end of a list"+        [PVal, PExp] fn'+ where+        fn' _world as0+         | Just (XApp tag@(XRef (RPrm PrimTagList)) xs, as1)+                          <- takeArgExp as0+         , Just (x1, [])  <- takeArgExp as1+         = return $ Just $ XApp tag (xs ++ [x1])+        fn' _world _+         = return $ Nothing+++-- | Unsnoc an element from the end of a list.+primOpListUnsnoc :: PrimEval s Prim w+primOpListUnsnoc+ = PrimEval+        (PrimOp "list-unsnoc")+        "split an element from the end of a list"+        [PVal, PExp] fn'+ where+        fn' _world as0+         | Just (XApp tag@(XRef (RPrm PrimTagList)) xx, as1)+                          <- takeArgExp as0+         , Just (x2, [])  <- takeArgExp as1+         = case reverse xx of+                x1 : xs -> return $ Just $ XApp x2 [XApp tag (reverse xs), x1]+                []      -> return $ Nothing++        fn' _world _+         = return $ Nothing+++-- | Append two lists.+primOpListAppend :: PrimEval s Prim w+primOpListAppend+ = PrimEval+        (PrimOp "list-append")+        "append two lists"+        [PVal, PVal] fn'+ where+        fn' _world as0+         | Just (XApp (XRef (RPrm PrimTagList)) xs1, as1)+                          <- takeArgExp as0+         , Just (XApp tag@(XRef (RPrm PrimTagList)) xs2, [])+                          <- takeArgExp as1+         = return $ Just (XApp tag (xs1 ++ xs2))++        fn' _world _+         = return $ Nothing+
+ SMR/Prim/Op/Match.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ParallelListComp  #-}+module SMR.Prim.Op.Match where+import SMR.Core.Exp+import SMR.Core.World+import SMR.Prim.Op.Base+import Data.IORef+++-- | Primitive matching operators.+primOpsMatch :: [PrimEval s Prim w]+primOpsMatch+ = [ primOpMatchSym+   , primOpMatchApp+   , primOpMatchAbs+   , primOpMatchAbs1 ]++++-- | Match against a given symbol.+primOpMatchSym :: PrimEval s Prim w+primOpMatchSym+ = PrimEval+        (PrimOp "match-sym")+        "match a symbol"+        [PVal, PExp, PExp] fn'+ where+        fn' _world as0+         | Just (x1, as1) <- takeArgExp as0+         , Just (x2, as2) <- takeArgExp as1+         , Just (x3, [])  <- takeArgExp as2+         = case x1 of+                XRef (RSym _s1)+                  -> return $ Just $ XApp x3 [x1]+                _ -> return $ Just $ x2++        fn' _world _+         = return $ Nothing+++-- | Match an application.+--   TODO: pack the args into a list+primOpMatchApp :: PrimEval s Prim w+primOpMatchApp+ = PrimEval+        (PrimOp "match-app")+        "match an application"+        [PVal, PExp, PExp] fn'+ where+        fn' _world as0+         | Just (x1, as1) <- takeArgExp as0+         , Just (x2, as2) <- takeArgExp as1+         , Just (x3, [])  <- takeArgExp as2+         = case x1 of+                XRef{}          -> return $ Nothing+                XKey{}          -> return $ Nothing+                XApp x11 xs12   -> return $ Just $ XApp x3 (x11 : xs12)+                XVar{}          -> return $ Nothing+                XAbs{}          -> return $ Just x2+                XSub{}          -> return $ Nothing++        fn' _world _+         = return $ Nothing++++-- | Match all parameters of an abstraction.+primOpMatchAbs :: PrimEval s Prim w+primOpMatchAbs+ = PrimEval+        (PrimOp "match-abs")+        "match all parameters of an abstraction"+        [PVal, PExp, PExp] fn'+ where+        fn' world as0+         | Just (x1, as1) <- takeArgExp as0+         , Just (x2, as2) <- takeArgExp as1+         , Just (x3, [])  <- takeArgExp as2+         = case x1 of+            XAbs ps11 x12 -> fnAbs world x3 ps11 x12+            _             -> return $ Just $ x2++        fn' _world _+         = return Nothing++        newNom world _+         = do   ix <- atomicModifyIORef (worldNomGen world)+                   $  \ix -> (ix + 1, ix)++                return ix++        fnAbs world x2 ps11 x12+         = do   -- Create new variables for each of the parameters.+                ixs     <- mapM (newNom world) ps11++                let boolOfForm PVal = True+                    boolOfForm PExp = False++                let xIxs+                        = makeXList+                                [ makeXList+                                        [ XRef (RNom ix)+                                        , XRef (RPrm (PrimLitBool (boolOfForm $ formOfParam p))) ]+                                | ix <- ixs | p  <- ps11 ]++                let xBody+                        = XSub  [CSim  (SSnv [BindVar (nameOfParam p) 0 (XRef (RNom ix))+                                              | p  <- ps11 | ix <- ixs ])]+                                 x12++                return  $ Just+                        $ XApp x2 (xIxs : [xBody])+++-- | Match the first parameter of an abstraction.+primOpMatchAbs1 :: PrimEval s Prim w+primOpMatchAbs1+ = PrimEval+        (PrimOp "match-abs1")+        "match the first parameter of an abstraction"+        [PVal, PExp, PExp] fn'+ where+        fn' world as0+         | Just (x1, as1) <- takeArgExp as0+         , Just (x2, as2) <- takeArgExp as1+         , Just (x3, [])  <- takeArgExp as2+         = case x1 of+            XRef{}        -> return $ Nothing+            XKey{}        -> return $ Nothing+            XApp{}        -> return $ Just x2+            XVar{}        -> return $ Nothing+            XAbs ps11 x12 -> fnAbs world x3 ps11 x12+            XSub{}        -> return $ Nothing++        fn' _world _+         = return Nothing++        newNom world _+         = do   ix <- atomicModifyIORef (worldNomGen world)+                   $  \ix -> (ix + 1, ix)++                return ix++        fnAbs _world _x2 [] _x12+         = return Nothing++        fnAbs world x2 (p1 : ps11) x12+         = do   ix      <- newNom world p1++                let boolOfForm PVal = True+                    boolOfForm PExp = False++                let xIx = makeXList+                        [ XRef (RNom ix)+                        , XRef (RPrm (PrimLitBool (boolOfForm $ formOfParam p1))) ]++                let xBody+                        = XSub [ CSim (SSnv [BindVar (nameOfParam p1) 0 (XRef (RNom ix))])]+                        $ makeXAbs ps11 x12++                return  $ Just+                        $ XApp x2 (xIx : [xBody])+
+ SMR/Prim/Op/Nat.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}+module SMR.Prim.Op.Nat where+import SMR.Core.Exp+import SMR.Prim.Op.Base+++type Nat = Integer++-- | Primitive evaluators for nat operators.+primOpsNat :: [PrimEval s Prim w]+primOpsNat+ = [ primOpNat2Nat  "nat-add" "natural addition"            (+)+   , primOpNat2Nat  "nat-sub" "natural subtration"+        (\a b -> let x = a - b+                 in if x < 0 then 0 else x)++   , primOpNat2Nat  "nat-mul" "natural multiplication"      (*)+   , primOpNat2Nat  "nat-div" "natural division"            div+   , primOpNat2Nat  "nat-rem" "natural remainder"           rem+   , primOpNat2Bool "nat-eq"  "natural equality"            (==)+   , primOpNat2Bool "nat-neq" "natural negated equality"    (/=)+   , primOpNat2Bool "nat-lt"  "natural less than"           (<)+   , primOpNat2Bool "nat-le"  "natural less than equal"     (<=)+   , primOpNat2Bool "nat-gt"  "natural greater than"        (>)+   , primOpNat2Bool "nat-ge"  "natural greather than equal" (>=) ]+++-- | Construct an evaluator for a 2-arity nat operator returning nat.+primOpNat2Nat+        :: Text -> Text -> (Nat -> Nat -> Nat)+        -> PrimEval s Prim w+primOpNat2Nat name desc fn+ =  PrimEval (PrimOp name) desc [PVal, PVal] fn'+ where  fn' _world as0+         | Just (n1, as1) <- takeArgNat as0+         , Just (n2, [])  <- takeArgNat as1+         = return $ Just $ makeXNat (fn n1 n2)+        fn' _world _+         = return $ Nothing+++-- | Construct an evaluator for a 2-arity nat operator returning bool.+primOpNat2Bool+        :: Text -> Text -> (Nat -> Nat -> Bool)+        -> PrimEval s Prim w+primOpNat2Bool name desc fn+ =  PrimEval (PrimOp name) desc [PVal, PVal] fn'+ where  fn' _world as0+         | Just (n1, as1) <- takeArgNat as0+         , Just (n2, [])  <- takeArgNat as1+         = return $ Just $ makeXBool (fn n1 n2)+        fn' _world _+         = return $ Nothing
+ SMR/Prim/Op/Nom.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings #-}+module SMR.Prim.Op.Nom where+import SMR.Prim.Op.Base+import SMR.Core.Exp.Base+import SMR.Core.World+import Data.IORef+++-- | Primitive evalutor for nominal variable operators.+primOpsNom :: [PrimEval s Prim w]+primOpsNom+ = [ primOpNomEq+   , primOpNomFresh+   , primOpNomClose ]+++-- | Check for equality of two nominal variables.+primOpNomEq :: PrimEval s Prim w+primOpNomEq+ = PrimEval+        (PrimOp "nom-eq")+        ("check equality of two nominal variables")+        [PVal, PVal] fn'+ where+        fn' _world as0+         | Just (XRef (RNom n1), as1) <- takeArgExp as0+         , Just (XRef (RNom n2), [])  <- takeArgExp as1+         = return $ Just+                  $ if n1 == n2 then XRef $ RPrm $ PrimLitBool True+                                else XRef $ RPrm $ PrimLitBool False+        fn' _world _+         = return $ Nothing+++-- | Allocate a fresh nominal variable.+primOpNomFresh :: PrimEval s Prim w+primOpNomFresh+ = PrimEval+        (PrimOp "nom-fresh")+        "allocate a fresh nominal variable"+        [PVal] fn'+ where+        fn' world as0+         | Just (XRef (RPrm PrimTagUnit), []) <- takeArgExp as0+         = do   ix  <- readIORef (worldNomGen world)+                writeIORef (worldNomGen world) (ix + 1)+                return $ Just $ XRef (RNom ix)++        fn' _world _+         = do   return $ Nothing+++-- | Create a closing substitution for a nominal variable.+primOpNomClose :: PrimEval s Prim w+primOpNomClose+ = PrimEval+        (PrimOp "nom-close")+        ("creating a closing substitution for a nominal variable")+        [PVal, PExp, PExp] fn'+ where+        fn' _world as0+         | Just (XRef (RNom n1), as1) <- takeArgExp as0+         , Just (x1, as2)  <- takeArgExp as1+         , Just (x2, [])   <- takeArgExp as2+         = return $ Just $ XSub [CSim (SSnv [BindNom n1 x1])] x2++        fn' _world _+         = return $ Nothing
+ SMR/Prim/Op/Sym.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+module SMR.Prim.Op.Sym where+import SMR.Prim.Op.Base+import SMR.Core.Exp.Base+++-- | Primitive evaluator for symbol operators.+primOpsSym :: Eq s => [PrimEval s Prim w]+primOpsSym+ = [ primOpSymEq ]+++-- | Check equality of two symbols.+primOpSymEq :: Eq s => PrimEval s Prim w+primOpSymEq+ = PrimEval+        (PrimOp "sym-eq")+        ("check equality of two symbols")+        [PVal, PVal] fn'+ where+        fn' _world as0+         | Just (XRef (RSym n1), as1) <- takeArgExp as0+         , Just (XRef (RSym n2), [])  <- takeArgExp as1+         = return $ Just+                  $ if n1 == n2 then XRef $ RPrm $ PrimLitBool True+                                else XRef $ RPrm $ PrimLitBool False+        fn' _world _+         = return $ Nothing
+ SMR/Source/Expected.hs view
@@ -0,0 +1,110 @@++module SMR.Source.Expected where+import SMR.Source.Parsec+import SMR.Source.Token+import SMR.Data.Located+import SMR.Data.Bag                     (Bag)+import Data.Text                        (Text)+import qualified SMR.Data.Bag           as Bag+import qualified Data.Text              as Text++-------------------------------------------------------------------------------+-- | What we were expecting at the point there was a parse error.+data Expected t s p+        -- | Expecting end of input.+        = ExBaseEnd++        -- | Expecting a name in the given namespace.+        | ExBaseNameOf  Space++        -- | Expecting a name in any namespace.+        | ExBaseNameAny++        -- | Expecting a natural number.+        | ExBaseNat++        -- | Expecting a text string.+        | ExBaseText++        -- | Expecting a punctuation character.+        | ExBasePunc    Char++        -- | Expecting something described by the given message.+        | ExBaseMsg     String++        -- | Expecting something while parsing a declaration.+        | ExContextDecl+                Text+                (Bag (Blocker t (Expected t s p)))++        -- | Expecting something while parsing a binding.+        | ExContextBind+                Text+                (Bag (Blocker t (Expected t s p)))+        deriving Show+++-- | Pretty print an expected thing.+pprExpected+        :: (Show s, Show p)+        => Expected (Located Token) s p -> String+pprExpected bb+ = case bb of+        ExBaseEnd       -> "expecting end of input"+        ExBaseNameOf s  -> "expecting name " ++ show s+        ExBaseNat       -> "expecting natural number"+        ExBaseText      -> "expecting text string"+        ExBasePunc c    -> "expecting " ++ show c+        ExBaseMsg t     -> "expecting " ++ show t+        ExBaseNameAny   -> "expecting name"++        ExContextDecl n es+         -> "in declaration @" ++ Text.unpack n ++ "\n"+         ++ (unlines $ map pprBlocker $ Bag.toList es)++        ExContextBind n esBag+         | e : _        <- Bag.toList esBag+         -> "in binding " ++ Text.unpack n ++ "\n"+         ++ pprBlocker e++         | otherwise+         -> "in binding " ++ Text.unpack n+++-- | Pretty print a blocker.+pprBlocker+        :: (Show s, Show p)+        => Blocker (Located Token) (Expected (Located Token) s p)+        -> String++pprBlocker (Blocker [] e)+ = pprExpected e++pprBlocker (Blocker (t : _) e)+ =  pprLocation (startOfLocated t)+ ++ " " ++ pprExpected e+++pprLocation :: Location -> String+pprLocation (L l c)+ = show l ++ ":" ++ show c+++-------------------------------------------------------------------------------+-- | Parser error.+data ParseError t e+        = ParseError [Blocker t e]+        deriving Show+++-- | Pretty print a parser error.+pprParseError+        :: (Show s, Show p)+        => ParseError (Located Token) (Expected (Located Token) s p) -> String++pprParseError (ParseError [])+ = "at end of input"++pprParseError (ParseError (b : _bs))+ = pprBlocker b+
+ SMR/Source/Lexer.hs view
@@ -0,0 +1,215 @@++module SMR.Source.Lexer+        ( lexTokens+        , Located (..)+        , Location(..))+where+import SMR.Source.Token+import SMR.Data.Located+import Data.Text                (Text)+import qualified Data.Text      as Text+import qualified Data.Char      as Char+++-- Lexer ----------------------------------------------------------------------+-- | Lex a sequence of tokens.+lexTokens :: Location -> [Char] -> ([Located Token], Location, [Char])+lexTokens lStart0 cs0+ = case skipSpace lStart0 cs0 of+    (lStart, [])+     -> ( LL lStart lStart KEnd : []+        , lStart, [])++    (lStart, cs)+     -> case lexToken lStart cs of+         Nothing+          -> ([], lStart, cs)++         Just (k, cs')+          |  (ks, lStart', cs'') <- lexTokens (endOfLocated k) cs'+          -> (k : ks, lStart', cs'')+++-- | Lex a single token.+lexToken :: Location -> [Char] -> Maybe (Located Token, [Char])+lexToken lStart xx+ = case xx of+    []+     -> Nothing++    c : cs+        -- Punctuation.+        |  isCharPunc c+        -> let  lEnd = incCharOfLocation 1 lStart+                tok  = KPunc c+           in   Just (LL lStart lEnd tok, cs)++        -- Variable name.+        |  Just (space, xx')         <- takeSpace c cs+        ,  Just (name, lEnd, csRest) <- lexName   (incCharOfLocation 1 lStart) xx'+        -> let  tok      = KName space name+           in   Just (LL lStart lEnd tok, csRest)++        --  Natural number.+        |  Char.isDigit c+        ,  Just (nat, lEnd, csRest)  <- lexNat lStart (c : cs)+        -> let  tok     = KNat nat+           in   Just (LL lStart lEnd tok, csRest)++        --  Text string.+        |  c == '\"'+        ,  Just (tx, lEnd, csRest)   <- lexText lStart cs+        -> let tok      = KText tx+           in   Just (LL lStart lEnd tok, csRest)++        |  otherwise+        -> Nothing+++-- | Lex a variable name.+lexName :: Location -> [Char] -> Maybe (Text, Location, [Char])+lexName lStart xx+ = go lStart [] xx+ where+        go lStart' acc []+         | not $ null acc+         = let  name    = Text.pack $ reverse acc+           in   Just (name, lStart', [])++         | otherwise+         = Nothing++        go lStart' acc (c : cs)+         | isNameBodyChar c+         =      go (incCharOfLocation 1 lStart') (c : acc) cs++         | otherwise+         = let  name    = Text.pack $ reverse acc+           in   Just (name, lStart', c : cs)+++-- | Lex a natural number.+lexNat  :: Location -> [Char] -> Maybe (Integer, Location, [Char])+lexNat lStart xx+ = go lStart [] xx+ where+        go lStart' acc []+         | not $ null acc+         , all Char.isDigit acc+         , nat <- read $ reverse acc+         = Just (nat, lStart', [])++        go lStart' acc (c : cs)+         | Char.isDigit c+         = go (incCharOfLocation 1 lStart') (c : acc) cs++         | all Char.isDigit acc+         , not $ null acc+         , nat <- read $ reverse acc+         = Just (nat, lStart', c : cs)++        go _ _ _+         = Nothing+++-- | Lex a string.+lexText :: Location -> [Char] -> Maybe (Text, Location, [Char])+lexText lStart xx+ = go lStart [] xx+ where+        go _ _ []+         = Nothing++        go lStart' acc ('\"' : cs)+         = Just (Text.pack $ reverse acc, lStart', cs)++        go lStart' acc ('\\' : c : cs)+         = let l' = incCharOfLocation 1 lStart'+           in  case c of+                '\"'    -> go l' (c    : acc) cs+                '\\'    -> go l' (c    : acc) cs+                'b'     -> go l' ('\b' : acc) cs+                'f'     -> go l' ('\f' : acc) cs+                'n'     -> go l' ('\n' : acc) cs+                'r'     -> go l' ('\r' : acc) cs+                't'     -> go l' ('\t' : acc) cs++                -- TODO: read hex encoded special chars.+                _       -> Nothing++        go lStart' acc (c : cs)+         = let l' = incCharOfLocation 1 lStart'+           in  go l' (c : acc) cs+++-- Whitespace -----------------------------------------------------------------+skipSpace :: Location -> [Char] -> (Location, [Char])+skipSpace lStart xx+ = case xx of+    []  -> (lStart, xx)++    c : cs+        -- Skip whitespace.+        | c == ' '  -> skipSpace (incCharOfLocation 1 lStart) cs+        | c == '\n' -> skipSpace (incLineOfLocation 1 lStart) cs+        | c == '\t' -> skipSpace (incCharOfLocation 8 lStart) cs++        -- Skip comments+        |  c  == '-'+        ,  c2 : cs2 <- cs+        ,  c2 == '-'+        -> skipSpace lStart $ dropWhile (\x -> x /= '\n') cs2++        | otherwise -> (lStart, xx)+++-- | Take the namespace qualifier from the front of a name.+takeSpace :: Char -> [Char] -> Maybe (Space, [Char])+takeSpace c cs+ | Char.isLower c = Just (SVar, c : cs)+ | c  == '@'    = Just (SMac, cs)+ | c  == '%'    = Just (SSym, cs)+ | c  == '+'    = Just (SSet, cs)+ | c  == '#'+ , c' : cs' <- cs+ , c' == '#'+ = Just (SKey, cs')++ | c == '#'     = Just (SPrm, cs)+ | otherwise    = Nothing+++-- Character Classes ----------------------------------------------------------+-- | Check if this character can appear in the body of a name.+isNameBodyChar :: Char -> Bool+isNameBodyChar c+ =  Char.isLower c+ || Char.isUpper c+ || Char.isDigit c+ || (c == '-' || c == '\'' || c == '_')+++-- | Check if this is a punctuation character.+isCharPunc :: Char -> Bool+isCharPunc c+ | c == '('     = True+ | c == ')'     = True+ | c == '{'     = True+ | c == '}'     = True+ | c == '['     = True+ | c == ']'     = True+ | c == '<'     = True+ | c == '>'     = True+ | c == '^'     = True+ | c == ','     = True+ | c == ':'     = True+ | c == '\\'    = True+ | c == '.'     = True+ | c == ';'     = True+ | c == '='     = True+ | c == '$'     = True+ | c == '!'     = True+ | c == '~'     = True+ | c == '?'     = True+ | otherwise    = False+
+ SMR/Source/Parsec.hs view
@@ -0,0 +1,367 @@++-- | Parser combinator framework.+module SMR.Source.Parsec where+import qualified SMR.Data.Bag   as Bag+import SMR.Data.Bag             (Bag)++-------------------------------------------------------------------------------+-- | Parser is a function that takes a list of tokens,+--   and returns a list of remaining tokens along with+--    (on error)   a list of descriptions of expected input,+--    (on success) a parsed value.+--+data Parser t e a+        = Parser ([t] -> ParseResult t e a)+++-- | Result of a parser,+--   parameterised by+--      (t) the type of tokens,+--      (e) the type for decriptions of what we're expecting to parse.+--      (a) type of value to parse.+--+data ParseResult t e a+        -- | Parser failed after consuming no input.+        --   The parser looked at one or more tokens at the front of the+        --   input but based on these the input does not look like whatever+        --   syntax the parser was supposed to parse.+        = ParseSkip+            (Bag (Blocker t e)) --  Where we got blocked trying other parses.++        -- | Parser yielding a value after consuming no input.+        --   The parser returned a value without looking at any tokens,+        --   this is a pure value returning action.+        | ParseReturn+            (Bag (Blocker t e)) --   Where we got blocked trying other parses.+            a                   --   Produced value.++        -- | Parse failed after partially consuming input.+        --   The parser thought that the input sequence looked like what it+        --   was supposed to parse, but complete parsing failed once it+        --   had committed.+        | ParseFailure+           (Bag (Blocker t e))  --   Where we got blocked trying other parses.++        -- | Parse succeeded yielding a value after consuming input.+        --   We have a complete value, and have consumed some input tokens.+        | ParseSuccess+            a                   --   Produced value.+           [t]                  --   Remaining input tokens.+        deriving Show+++-- | Describes why the parser could not make further progress.+data Blocker t e+        = Blocker+        { blockerTokens   :: [t] -- ^ Remaining input tokens where we failed.+        , blockerExpected :: e   -- ^ Description of what we were expecting.+        }+        deriving Show+++-------------------------------------------------------------------------------+-- | Apply a parser to a list of input tokens.+parse :: Parser t e a -> [t] -> ParseResult t e a+parse (Parser p) ts = p ts+++-- Functor --------------------------------------------------------------------+instance Functor (Parser t e) where+ fmap f parserA+  = Parser $ \ts0+  -> case parse parserA ts0 of+        ParseSkip    bs1        -> ParseSkip    bs1+        ParseReturn  bs1 x      -> ParseReturn  bs1 (f x)+        ParseFailure bs1        -> ParseFailure bs1+        ParseSuccess a ts1      -> ParseSuccess (f a) ts1+++-- Applicative ----------------------------------------------------------------+instance Applicative (Parser t e) where+ pure x+  = Parser $ \_+  -> ParseReturn Bag.nil x++ (<*>) parserF parserA+  = Parser $ \ts0+  -> case parse parserF ts0 of+        ParseSkip es1+         -> ParseSkip es1++        ParseFailure bs1+         -> ParseFailure bs1++        ParseReturn es1 f+         -> case parse parserA ts0 of+             ParseSkip    es2   -> ParseSkip    (Bag.union es1 es2)+             ParseReturn  es2 x -> ParseReturn  (Bag.union es1 es2) (f x)+             ParseFailure bs2   -> ParseFailure (Bag.union es1 bs2)+             ParseSuccess x ts2 -> ParseSuccess (f x) ts2++        ParseSuccess f ts1+         -> case parse parserA ts1 of+             ParseSkip    bs2   -> ParseFailure bs2+             ParseReturn  _ x   -> ParseSuccess (f x) ts1+             ParseFailure bs2   -> ParseFailure bs2+             ParseSuccess x ts2 -> ParseSuccess (f x) ts2+++-- Monad ----------------------------------------------------------------------+instance Monad (Parser t e) where+ return x+  = Parser $ \_+  -> ParseReturn Bag.nil x++ (>>=) parserA mkParserB+  = Parser $ \ts0+  -> case parse parserA ts0 of+        ParseSkip bs1+         -> ParseSkip bs1++        ParseFailure bs1+         -> ParseFailure bs1++        -- First parser produced a value but did not consume input.+        ParseReturn _ xa+         -> parse (mkParserB xa) ts0++        -- First parser produced a value and consumed input.+        ParseSuccess xa ts1+         -> case parse (mkParserB xa) ts1 of+             -- The second parser skipped, but as we've already consumed+             -- input tokens we treat this as a failure.+             ParseSkip    bs2    -> ParseFailure bs2++             -- The second parser returned a value, and though it didn't+             -- consume input itself, the whole computation has,+             -- so still treat this as a success.+             ParseReturn  _ xb   -> ParseSuccess xb ts1++             -- The second parser failed.+             ParseFailure bs2    -> ParseFailure bs2++             -- The second parser suceeded, to take the new value.+             ParseSuccess xb ts2 -> ParseSuccess xb ts2+++-- Prim -----------------------------------------------------------------------+-- Primitive parsers.++-- | Always fail, producing no possible parses and no helpful error message.+fail :: Parser t e a+fail+ =  Parser $ \_+ -> ParseFailure Bag.nil+++-- | Always fail, yielding the given message describing what was expected.+expected :: e -> Parser t e a+expected xe+ =  Parser $ \ts+ -> ParseFailure (Bag.singleton (Blocker ts xe))+++-- | Commit to the given parser, so if it skips or returns without+--   consuming any input then treat that as failure.+commit :: Parser t e a -> Parser t e a+commit parserA+ =  Parser $ \ts0+ -> case parse parserA ts0 of+        ParseSkip    bs1        -> ParseFailure bs1+        ParseReturn  bs1 _      -> ParseFailure bs1+        ParseFailure bs1        -> ParseFailure bs1+        ParseSuccess xb xs2     -> ParseSuccess xb xs2+++-- | Parse in an expectation context.+enter :: (Bag (Blocker t e) -> e) -> Parser t e a -> Parser t e a+enter mk parserA+ = Parser $ \ts0+ -> case parse parserA ts0 of+        ParseSkip    bs1+         -> ParseSkip    (Bag.singleton (Blocker ts0 (mk bs1)))++        ParseReturn  bs1 x+         -> ParseReturn  (Bag.singleton (Blocker ts0 (mk bs1))) x++        ParseFailure bs1+         -> ParseFailure (Bag.singleton (Blocker ts0 (mk bs1)))++        ParseSuccess xb ts2+         -> ParseSuccess xb ts2+++-- | If the given parser suceeds then enter an expectation context+--   for the next one.+enterOn :: Parser t e a+        -> (a -> Bag (Blocker t e) -> e)+        -> (a -> Parser t e b)+        -> Parser t e b++enterOn parserA mk mkParserB+ = Parser $ \ts0+ -> case parse parserA ts0 of+        ParseSkip bs0+         -> ParseSkip bs0++        ParseFailure bs1+         -> ParseFailure bs1++        ParseReturn _ xa+         -> case parse (mkParserB xa) ts0 of+                ParseSkip bs2+                 -> ParseSkip    (Bag.singleton (Blocker ts0 (mk xa bs2)))++                ParseReturn bs2 xb+                 -> ParseReturn  (Bag.singleton (Blocker ts0 (mk xa bs2))) xb++                ParseFailure bs2+                 -> ParseFailure (Bag.singleton (Blocker ts0 (mk xa bs2)))++                ParseSuccess xb ts2+                 -> ParseSuccess xb ts2+++        ParseSuccess xa ts1+         -> case parse (mkParserB xa) ts1 of+                ParseSkip bs2+                 -> ParseSkip    (Bag.singleton (Blocker ts0 (mk xa bs2)))++                ParseReturn bs2 xb+                 -> ParseReturn  (Bag.singleton (Blocker ts0 (mk xa bs2))) xb++                ParseFailure bs2+                 -> ParseFailure (Bag.singleton (Blocker ts0 (mk xa bs2)))++                ParseSuccess xb ts2+                 -> ParseSuccess xb ts2+++-- | Peek at the first input token, without consuming at it.+peek :: Parser t e t+peek+ = Parser $ \ts+ -> case ts of+        []              -> ParseFailure Bag.nil+        t : _           -> ParseReturn  Bag.nil t+++-- | Consume the first input token, failing if there aren't any.+item :: e -> Parser t e t+item xe+ = Parser $ \ts+ -> case ts of+        []              -> ParseSkip   (Bag.singleton (Blocker ts xe))+        t : ts'         -> ParseSuccess t ts'+++-- | Consume the first input token if it matches the given predicate,+--   failing without consuming if the predicate does not match.+satisfies :: e -> (t -> Bool) -> Parser t e t+satisfies xe p+ = Parser $ \ts+ -> case ts of+        []              -> ParseSkip    (Bag.singleton (Blocker ts xe))+        t : ts'+         | p t          -> ParseSuccess t ts'+         | otherwise    -> ParseSkip    (Bag.singleton (Blocker ts xe))+++-- | Consume the first input token if it is accepted by the given match+--   function. Fail without consuming if there is no match.+from :: e -> (t -> Maybe a) -> Parser t e a+from xe accept+ = Parser $ \ts+ -> case ts of+        []              -> ParseSkip    (Bag.singleton (Blocker ts xe))+        t : ts'+         -> case accept t of+               Just x   -> ParseSuccess x ts'+               Nothing  -> ParseSkip    (Bag.singleton (Blocker ts xe))+++-- | Given two parsers, try the first and if it succeeds produce+--   the output of that parser, if not try the second.+alt :: Parser t e a -> Parser t e a -> Parser t e a+alt parserA parserB+ = alts (parserA : parserB : [])+++-- | Like 'alt' but take a list of parser, trying them in order.+alts :: [Parser t e a] -> Parser t e a+alts parsers+ = Parser $ \ts0+ -> go ts0 (False, Nothing) (Bag.nil, Bag.nil) parsers+ where+        go _   (False, Nothing)  (bsSkip, _bsFail) []+         = ParseSkip    bsSkip++        go _   (False, (Just x)) (bsSkip, _bsFail) []+         = ParseReturn  bsSkip x++        go _   (True,  _)        (_bsSkip, bsFail) []+         = ParseFailure bsFail++        go ts0 (failed, mx)      (bsSkip, bsFail) (p : ps)+         = case parse p ts0 of+            ParseSkip    bs1+             -> go ts0 (failed, mx)     (Bag.union bsSkip bs1, bsFail) ps++            ParseFailure bs1+             -> go ts0 (True,   mx)     (bsSkip, Bag.union bsFail bs1) ps++            ParseReturn  bs1 x+             -> go ts0 (failed, Just x) (Bag.union bsSkip bs1, bsFail) ps++            ParseSuccess x ts1+             -> ParseSuccess  x ts1+++-- Derived --------------------------------------------------------------------+-- Parsers derived from the primitive ones.++-- | Parse zero or more things, yielding a list of those things.+some :: Parser t e a -> Parser t e [a]+some parserA+ = alt (do+        x       <- parserA+        xs      <- some parserA+        return  $ x : xs)+       (return [])+++-- | Parse one or more things, yielding a list of those things.+many :: Parser t e a -> Parser t e [a]+many parserA+ = do   x       <- parserA+        xs      <- some parserA+        return  $ x : xs+++-- | Parse some things separated by other things.+sepBy   :: Parser t e a -> Parser t e s -> Parser t e [a]+sepBy parserA parserS+ = alt  (sepBy1 parserA parserS)+        (return [])+++-- | Parse at least one thing separated by other things.+sepBy1  :: Parser t e a -> Parser t e s -> Parser t e [a]+sepBy1 parserA parserS+ = do   x       <- parserA+        alt+         (do    _s      <- parserS+                xs      <- sepBy1 parserA parserS+                return  $ x : xs)++         (do    return  $ x : [])+++-- | Run a parser, peeking at the starting and ending tokens.+withDelims :: Parser t e a -> Parser t e (t, a, t)+withDelims p+ = do   kStart  <- peek+        x       <- p+        kEnd    <- peek+        return  (kStart, x, kEnd)+
+ SMR/Source/Parser.hs view
@@ -0,0 +1,369 @@++module SMR.Source.Parser where+import SMR.Core.Exp.Base+import SMR.Source.Expected+import SMR.Source.Token+import SMR.Source.Lexer+import SMR.Data.Located++import Data.Text                        (Text)++import qualified SMR.Source.Parsec      as P+import qualified SMR.Data.Bag           as Bag+import qualified Data.Text              as Text+++-------------------------------------------------------------------------------+type Parser s p a+        = P.Parser (Located Token) (Expected (Located Token) s p) a++type Error s p+         = ParseError (Located Token) (Expected (Located Token) s p)++data Config s p+        = Config+        { configReadSym  :: Text -> Maybe s+        , configReadPrm  :: Text -> Maybe p }+++-- Interface ------------------------------------------------------------------+-- | Parse some Shimmer declarations from a list of tokens.+parseDecls+        :: Config s p           -- ^ Primop configration.+        -> [Located Token]      -- ^ Tokens to parse.+        -> Either (Error s p) [Decl s p]+parseDecls c ts+ = case P.parse pDeclsEnd ts of+        P.ParseSkip    es       -> Left $ ParseError (Bag.toList es)+        P.ParseReturn  _ xx     -> Right xx+        P.ParseFailure bs       -> Left $ ParseError (Bag.toList bs)+        P.ParseSuccess xx _     -> Right xx+ where+        pDeclsEnd+         = do   ds      <- pDecls c+                _       <- pEnd+                return ds+++-- | Parse a Shimmer expression from a list of tokens.+parseExp+        :: Config s p           -- ^ Primop configuration.+        -> [Located Token]      -- ^ Tokens to parse.+        -> Either (Error s p) (Exp s p)+parseExp c ts+ = case P.parse pExpEnd ts of+        P.ParseSkip    es       -> Left $ ParseError (Bag.toList es)+        P.ParseReturn  _ xx     -> Right xx+        P.ParseFailure bs       -> Left $ ParseError (Bag.toList bs)+        P.ParseSuccess xx _     -> Right xx+ where+        pExpEnd+         = do   x       <- pExp c+                _       <- pEnd+                return x+++-- Decl -----------------------------------------------------------------------+-- | Parser for a list of declarations.+pDecls  :: Config s p -> Parser s p [Decl s p]+pDecls c+ =      P.some (pDecl c)+++-- | Parser for a single declaration.+pDecl   :: Config s p -> Parser s p (Decl s p)+pDecl c+ = P.alts+ [ P.enterOn (pNameOfSpace SMac) ExContextDecl $ \name+    -> do psParam <- P.some pParam+          _       <- pPunc '='+          xBody   <- pExp c+          _       <- pPunc ';'+          if length psParam == 0+           then return (DeclMac name xBody)+           else return (DeclMac name $ XAbs psParam xBody)++ , P.enterOn (pNameOfSpace SSet) ExContextDecl $ \name+    -> do _       <- pPunc '='+          xBody   <- pExp c+          _       <- pPunc ';'+          return (DeclSet name xBody)+ ]+++-- Exp ------------------------------------------------------------------------+-- | Parser for an expression.+pExp :: Config s p -> Parser s p (Exp s p)+pExp c+        -- Abstraction.+ = P.alts+ [ do   _       <- pPunc '\\'+        psParam <- P.some pParam+        _       <- pPunc '.'+        xBody   <- pExp c+        return  $ XAbs  psParam xBody++        -- Substitution train.+ , do   csTrain <- pTrain c+        _       <- pPunc '.'+        xBody   <- pExp c+        return  $  XSub (reverse csTrain) xBody++        -- Application possibly using '$'+ , do   xHead   <- pExpApp c+        P.alt+            (do _       <- pPunc '$'+                xRest   <- pExp c+                return  $  XApp xHead [xRest])+            (return xHead)+ ]+++-- | Parser for an application.+pExpApp :: Config s p -> Parser s p (Exp s p)+pExpApp c+        -- Application of a superprim.+ = P.alts+ [ do   nKey+         <- do  nKey'   <- pNameOfSpace SKey+                if       nKey' == Text.pack "box" then return KBox+                 else if nKey' == Text.pack "run" then return KRun+                 else P.fail++        xArg    <- pExpAtom c+        return $ XKey nKey xArg++        -- Application of some other expression.+ , do   xFun    <- pExpAtom c+        xsArgs  <- P.some (pExpAtom c)+        case xsArgs of+         []  -> return $ xFun+         _   -> return $ XApp xFun xsArgs+ ]+++-- | Parser for an atomic expression.+pExpAtom :: Config s p -> Parser s p (Exp s p)+pExpAtom c+        -- Parenthesised expression.+ = P.alts+ [ do   _       <- pPunc '('+        x       <- pExp c+        _       <- pPunc ')'+        return x++        -- Nominal variable.+ , do   _ <- pPunc '?'+        n <- pNat+        return $ XRef (RNom n)++        -- Text string.+ , do   tx <- pText+        return $ XRef (RTxt tx)++        -- Named variable with or without index.+ , do   (space, name) <- pName++        case space of+         -- Named variable.+         SVar+          -> P.alt (do  _       <- pPunc '^'+                        ix      <- pNat+                        return  $ XVar name ix)+                   (return $ XVar name 0)++         -- Named macro.+         SMac -> return $ XRef (RMac name)++         -- Named set.+         SSet -> return $ XRef (RSet name)++         -- Named symbol+         SSym+          -> case configReadSym c name of+                Just s  -> return (XRef (RSym s))+                Nothing -> P.fail++         -- Named primitive.+         SPrm+          -> case configReadPrm c name of+                Just p  -> return (XRef (RPrm p))+                Nothing -> P.fail++         -- Named keyword.+         SKey -> P.fail++         -- Named nominal (should be handled above)+         SNom -> P.fail+ ]+++-- Param ----------------------------------------------------------------------+-- | Parser for a function parameter.+pParam  :: Parser s p Param+pParam+ = P.alts+ [ do   _       <- pPunc '!'+        n       <- pNameOfSpace SVar+        return  $  PParam n PVal++ , do   _       <- pPunc '~'+        n       <- pNameOfSpace SVar+        return  $  PParam n PExp++ , do   n       <- pNameOfSpace SVar+        return  $  PParam n PVal++ ]+++-- Train ----------------------------------------------------------------------+-- | Parser for a substitution train.+--   The cars are produced in reverse order.+pTrain  :: Config s p -> Parser s p [Car s p]+pTrain c+ = do   cCar    <- pTrainCar c+        P.alt+         (do csCar <- pTrain c+             return $ cCar : csCar)+         (do return $ cCar : [])+++-- | Parse a single car in the train.+pTrainCar :: Config s p -> Parser s p (Car s p)+pTrainCar c+ = P.alt+        -- Substitution, both simultaneous and recursive+    (do car     <- pCarSimRec c+        return car)++    (do -- An ups car.+        ups     <- pUps+        return (CUps ups))+++-- Snv ------------------------------------------------------------------------+-- | Parser for a substitution environment.+--+-- @+-- Snv   ::= '[' Bind*, ']'+-- @+--+pCarSimRec :: Config s p -> Parser s p (Car s p)+pCarSimRec c+ = do   _       <- pPunc '['++        P.alt   -- Recursive substitution.+         (do    _       <- pPunc '['+                bs      <- P.sepBy (pBind c) (pPunc ',')+                _       <- pPunc ']'+                _       <- pPunc ']'+                return  $ CRec (SSnv (reverse bs)))++                -- Simultaneous substitution.+         (do    bs      <- P.sepBy (pBind c) (pPunc ',')+                _       <- pPunc ']'+                return  $ CSim (SSnv (reverse bs)))+++-- | Parser for a binding.+--+-- @+-- Bind ::= Name '=' Exp+--       |  Name '^' Nat '=' Exp+-- @+--+pBind   :: Config s p -> Parser s p (SnvBind s p)+pBind c+ = P.alt+        (P.enterOn (pNameOfSpace SVar) ExContextBind $ \name+         -> P.alt+                (do _       <- pPunc '='+                    x       <- pExp c+                    return  $ BindVar name 0 x)++                (do _       <- pPunc '^'+                    bump    <- pNat+                    _       <- pPunc '='+                    x       <- pExp c+                    return  $ BindVar name bump x))++        (do pPunc '?'+            ix <- pNat+            _  <- pPunc '='+            x  <- pExp c+            return $ BindNom ix x)+++-- Ups ------------------------------------------------------------------------+-- | Parser for an ups.+--+-- @+-- Ups  ::= '{' Bump*, '}'+-- @+--+pUps :: Parser s p Ups+pUps+ = do   _       <- pPunc '{'+        bs      <- P.sepBy pBump (pPunc ',')+        _       <- pPunc '}'+        return  $ UUps (reverse bs)+++-- | Parser for a bump.+--+-- @+-- Bump ::= Name ':' Nat+--       |  Name '^' Nat ':' Nat+-- @+pBump :: Parser s p UpsBump+pBump+ = do   name    <- pNameOfSpace SVar+        P.alt+         (do    _       <- pPunc ':'+                inc     <- pNat+                return  ((name, 0), inc))++         (do    _       <- pPunc '^'+                depth   <- pNat+                _       <- pPunc ':'+                inc     <- pNat+                return  ((name, depth), inc))+++-------------------------------------------------------------------------------+-- | Parser for a natural number.+pNat  :: Parser s p Integer+pNat  =  P.from ExBaseNat  (takeNatOfToken . valueOfLocated)+++-- | Parser for a text string.+pText :: Parser s p Text+pText =  P.from ExBaseText (takeTextOfToken . valueOfLocated)+++-- | Parser for a name in the given name space.+pNameOfSpace :: Space -> Parser s p Text+pNameOfSpace s+ = P.from (ExBaseNameOf s) (takeNameOfToken s . valueOfLocated)+++-- | Parser for a name of any space.+pName :: Parser s p (Space, Text)+pName+ = P.from ExBaseNameAny    (takeAnyNameOfToken . valueOfLocated)+++-- | Parser for the end of input token.+pEnd  :: Parser s p ()+pEnd+ = do   _ <- P.satisfies ExBaseEnd (isToken KEnd . valueOfLocated)+        return ()+++-- | Parser for a punctuation character.+pPunc  :: Char -> Parser s p ()+pPunc c+ = do   _ <- P.satisfies (ExBasePunc c) (isToken (KPunc c) . valueOfLocated)+        return ()+
+ SMR/Source/Pretty.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE OverloadedStrings #-}+module SMR.Source.Pretty where+import SMR.Core.Exp.Base+import SMR.Prim.Name+import Data.Monoid+import Data.Text                                (Text)+import Data.Text.Lazy.Builder                   (Builder)+import qualified Data.Text.Lazy.Builder         as B+import qualified Data.Text.Lazy                 as L+import qualified Data.Text                      as T+import qualified Data.Char                      as Char+import qualified Numeric                        as Numeric+++-- Class ----------------------------------------------------------------------+-- | Class of things that can be converted to text builders.+class Build a where+ build  :: a -> Builder++instance Build Text where+ build tx = B.fromText tx++instance Build Prim where+ build pp = buildPrim pp++instance (Build s, Build p) => Build (Exp s p) where+ build xx = buildExp CtxTop xx+++-- | Context we're currently in when pretty printing.+data Ctx+        = CtxTop        -- ^ Top level context.+        | CtxFun        -- ^ Functional expression in an an application.+        | CtxArg        -- ^ Argument expression in an application.+        deriving Show+++-- | Wrap a thing in parenthesis.+parens :: Builder -> Builder+parens bb+ = "(" <> bb <> ")"+++-- | Pretty print a thing as strict `Text`.+pretty :: Build a => a -> Text+pretty x+ = L.toStrict $ B.toLazyText $ build x+++-- Decl -----------------------------------------------------------------------+-- | Yield a builder for a declaration.+buildDecl+        :: (Build s, Build p)+        => Decl s p -> Builder+buildDecl dd+ = case dd of+        DeclMac n xx+         -> "@" <> B.fromText n <> " = " <> buildExp CtxTop xx <> ";\n"++        DeclSet n xx+         -> "+" <> B.fromText n <> " = " <> buildExp CtxTop xx <> ";\n"+++-- Exp ------------------------------------------------------------------------+-- | Yield a builder for an expression.+buildExp+        :: (Build s, Build p)+        => Ctx -> Exp s p -> Builder+buildExp ctx xx+ = case xx of+        XRef r    -> buildRef r++        XVar n 0  -> B.fromText n+        XVar n d  -> B.fromText n <> "^" <> B.fromString (show d)++        XKey k1 x2+         -> let ppExp   = buildKey k1 <> " " <> buildExp CtxArg x2+            in  case ctx of+                 CtxArg -> parens ppExp+                 _      -> ppExp++        XApp x1 []+         -> buildExp CtxFun x1++        XApp x1 xs2+         -> let ppExp   =  buildExp CtxFun x1 <> " " <> go xs2+                go []               = ""+                go (x : [])         = buildExp CtxArg x+                go (x11 : x21 : xs) = buildExp CtxArg x11 <> " " <> go (x21 : xs)+            in case ctx of+                CtxArg  -> parens ppExp+                _       -> ppExp++        XAbs vs x+         -> let go []        = "."+                go (p1 : []) = buildParam p1 <> "."+                go (p1 : ps) = buildParam p1 <> " " <> go ps+                ss           = "\\" <> go vs <> buildExp CtxTop x+            in  case ctx of+                 CtxArg -> parens ss+                 CtxFun -> parens ss+                 _      -> ss++        XSub train x+         |  length train == 0+         -> buildExp ctx x+         |  otherwise+         -> let ss     = buildTrain train <> "." <> buildExp CtxTop x+            in  case ctx of+                 CtxArg  -> parens ss+                 CtxFun  -> parens ss+                 _       -> ss+++-- | Yield a builder for a parameter.+buildParam :: Param -> Builder+buildParam pp+ = case pp of+        PParam n PVal    -> B.fromText n+        PParam n PExp    -> "~" <> B.fromText n+++-- | Yield a builder for a keyword.+buildKey :: Key -> Builder+buildKey kk+ = case kk of+        KBox    -> "##box"+        KRun    -> "##run"+++-- Train ----------------------------------------------------------------------+-- | Yield a builder for a train.+buildTrain  :: (Build s, Build p) => Train s p -> Builder+buildTrain cs0+ = go cs0+ where  go []           = ""+        go (c : cs)     = go cs <> buildCar c+++-- | Yield a builder for a train car.+buildCar :: (Build s, Build p) => Car s p -> Builder+buildCar cc+ = case cc of+        CSim snv        -> buildSnv snv+        CRec snv        -> "[" <> buildSnv snv <> "]"+        CUps ups        -> buildUps ups+++-- Snv ------------------------------------------------------------------------+-- | Yield a builder for a substitution.+buildSnv  :: (Build s, Build p) => Snv s p -> Builder+buildSnv (SSnv vs)+ = "[" <> go (reverse vs) <> "]"+ where  go []   = ""+        go (b : [])     = buildSnvBind b+        go (b : bs)     = buildSnvBind b <> ", " <> go bs+++-- | Yield a builder for a substitution binding.+buildSnvBind :: (Build s, Build p) => SnvBind s p -> Builder+buildSnvBind (BindVar name bump xx)+ | bump == 0+ = B.fromText name+ <> "=" <> buildExp CtxTop xx++ | otherwise+ =  B.fromText name <> "^" <> B.fromString (show bump)+ <> "=" <> buildExp CtxTop xx++buildSnvBind (BindNom ix xx)+ =  "?" <> B.fromString (show ix)+ <> "=" <> buildExp CtxTop xx+++-- Ups ------------------------------------------------------------------------+-- | Yield a builder for an ups.+buildUps :: Ups -> Builder+buildUps (UUps vs)+ = "{" <> go (reverse vs) <> "}"+ where  go []   = ""+        go (b : [])     = buildUpsBump b+        go (b : bs)     = buildUpsBump b <> ", " <> go bs+++-- | Yield a builder for an ups bump.+buildUpsBump :: UpsBump -> Builder+buildUpsBump ((name, bump), inc)+ | bump == 0+ = B.fromText name+ <> "=" <> B.fromString (show inc)++ | otherwise+ =  B.fromText name <> "^" <> B.fromString (show bump)+ <> "=" <> B.fromString (show inc)+++-- Ref ------------------------------------------------------------------------+-- | Yield a builder for a reference.+buildRef :: (Build s, Build p) => Ref s p -> Builder+buildRef rr+ = case rr of+        RSym s  -> "%" <> build s+        RPrm p  -> "#" <> build p+        RTxt t  -> buildText t+        RMac n  -> "@" <> B.fromText n+        RSet n  -> "+" <> B.fromText n+        RNom i  -> "?" <> B.fromString (show i)+++-- | Build a text string, escaping special chars in JSON style.+buildText :: Text -> Builder+buildText tx+ = (B.fromString $ ['"'] ++ escape (T.unpack tx) ++ ['"'])+ where  escape []               = []++        escape ('\\' : cs)      = '\\' : '\\' : escape cs+        escape ('\"' : cs)      = '\\' : '\"' : escape cs+        escape ('\b' : cs)      = '\\' : '\b' : escape cs+        escape ('\f' : cs)      = '\\' : '\f' : escape cs+        escape ('\n' : cs)      = '\\' : '\n' : escape cs+        escape ('\r' : cs)      = '\\' : '\r' : escape cs+        escape ('\t' : cs)      = '\\' : '\t' : escape cs++        escape (c : cs)+         | Char.ord c >= 32 && Char.ord c <= 126+         = c : escape cs++         | otherwise+         = let  s       = Numeric.showHex (Char.ord c) ""+                ss      = replicate (4 - length s) '0' ++ s+           in   "\\u" ++ ss ++ escape cs+++-- Prim -----------------------------------------------------------------------+-- | Yield a builder for a primitive.+buildPrim :: Prim -> Builder+buildPrim pp+ = B.fromText $ pprPrim pp+
+ SMR/Source/Token.hs view
@@ -0,0 +1,73 @@++module SMR.Source.Token where+import Data.Text (Text)+++-- | Tokens for for the source language.+data Token+        = KEnd                  -- ^ End of input.+        | KPunc Char            -- ^ Punctuation character.+        | KName Space Text      -- ^ A scoped name.+        | KNat  Integer         -- ^ A literal natural number.+        | KText Text            -- ^ A literal text string.+        deriving (Show, Eq)+++-- | Name space of a name.+data Space+        = SVar                  -- ^ Local variable.+        | SMac                  -- ^ Macro name.+        | SSym                  -- ^ Symbol name.+        | SSet                  -- ^ Set name.+        | SPrm                  -- ^ Primitive name.+        | SKey                  -- ^ Keyword (super primitive)+        | SNom                  -- ^ Nominal name.+        deriving (Show, Eq)+++-- | Check if a token is equal to the give none.+isToken :: Token -> Token -> Bool+isToken k1 k2 = k1 == k2+++-- | Check is token is punctuation using the given character.+isKPunc :: Char -> Token -> Bool+isKPunc c k+ = case k of+        KPunc c' -> c == c'+        _        -> False+++-- | Take the name from a token, if any.+takeNameOfToken :: Space -> Token -> Maybe Text+takeNameOfToken ss1 kk+ = case kk of+        KName ss2 n+         | ss1 == ss2   -> Just n+         | otherwise    -> Nothing+        _               -> Nothing+++-- | Take the name from a token, if any.+takeAnyNameOfToken :: Token -> Maybe (Space, Text)+takeAnyNameOfToken kk+ = case kk of+        KName ss2 n     -> Just (ss2, n)+        _               -> Nothing+++-- | Take the natural number from a token, if any.+takeNatOfToken :: Token -> Maybe Integer+takeNatOfToken kk+ = case kk of+        KNat n          -> Just n+        _               -> Nothing+++-- | Take the text string from a token, if any.+takeTextOfToken :: Token -> Maybe Text+takeTextOfToken kk+ = case kk of+        KText tx        -> Just tx+        _               -> Nothing+
shimmer.cabal view
@@ -1,5 +1,5 @@ name:           shimmer-version:        0.1.1+version:        0.1.2 license:        MIT license-file:   LICENSE author:         Ben Lippmeier <benl@ouroborus.net>@@ -11,8 +11,8 @@ synopsis:       The Reflective Lambda Machine  library- hs-source-dirs:-        src+ ghc-options:+        -O2   build-depends:         base            >= 4.10  && < 4.11,@@ -24,26 +24,15 @@         haskeline       >= 0.7   && < 0.8   exposed-modules:-        SMR.Codec.Peek-        SMR.Codec.Poke-        SMR.Codec.Size +        SMR.Core.Codec         SMR.Core.Exp         SMR.Core.Step-        SMR.Core.World          SMR.Data.Bag         SMR.Data.Located          SMR.Prim.Name--        SMR.Prim.Op.Base-        SMR.Prim.Op.Bool-        SMR.Prim.Op.List-        SMR.Prim.Op.Match-        SMR.Prim.Op.Nat-        SMR.Prim.Op.Nom-        SMR.Prim.Op.Sym         SMR.Prim.Op          SMR.Source.Expected@@ -59,11 +48,25 @@         SMR.CLI.Help         SMR.CLI.Repl +        SMR.Core.Codec.Peek+        SMR.Core.Codec.Poke+        SMR.Core.Codec.Size+        SMR.Core.Codec.Word++        SMR.Core.World+         SMR.Core.Exp.Base         SMR.Core.Exp.Compounds         SMR.Core.Exp.Push         SMR.Core.Exp.Train +        SMR.Prim.Op.Base+        SMR.Prim.Op.Bool+        SMR.Prim.Op.List+        SMR.Prim.Op.Match+        SMR.Prim.Op.Nat+        SMR.Prim.Op.Nom+        SMR.Prim.Op.Sym   extensions:         PatternGuards
− src/SMR/CLI/Config.hs 
@@ -1,75 +0,0 @@--module SMR.CLI.Config where-import qualified System.Exit    as System----- | Command line mode.-data Mode-        -- No mode specified.-        = ModeNone--        -- Parse and check a .smr source file.-        | ModeCheck FilePath--        -- Start the REPL with the given file.-        | ModeREPL  (Maybe FilePath)--        -- Convert a file from one format to another.-        | ModeConvert FilePath FilePath-        deriving Show----- | Command line config.-data Config-        = Config-        { configMode    :: Mode }-        deriving Show---configZero :: Config-configZero-        = Config-        { configMode    = ModeNone }----- | Parse command-line arguments.-parseArgs :: [String] -> Config -> IO Config-parseArgs [] config- = return config--parseArgs ss config- | "-check" : filePath : ssRest <- ss- = parseArgs ssRest- $ config { configMode = ModeCheck filePath }-- | "-convert" : fileSource : fileDest : ssRest <- ss- = parseArgs ssRest- $ config { configMode = ModeConvert fileSource fileDest }-- | "-help"  : _ssRest <- ss- = do   putStr usage-        System.exitSuccess-- | "--help"  : _ssRest <- ss- = do   putStr usage-        System.exitSuccess--- | filePath : ssRest <- ss- , c : _       <- filePath- , c /= '-'- = parseArgs ssRest- $ config { configMode  = ModeREPL (Just filePath) }-- | otherwise- = do   putStr usage-        System.exitSuccess--usage :: String-usage- = unlines- [ "shimmer                       Start the REPL with no soure file."- , "shimmer FILE                  Start the REPL with the given file."- , "shimmer -help                 Display this help page."- , "shimmer -check FILE           Check that a source file is well formed."- , "shimmer -convert FILE1 FILE2  Convert file from one format to another." ]
− src/SMR/CLI/Driver/Load.hs 
@@ -1,53 +0,0 @@--module SMR.CLI.Driver.Load-        (runLoadFileDecls)-where-import qualified SMR.Prim.Op                    as Prim-import qualified SMR.Prim.Name                  as Prim-import qualified SMR.Source.Parser              as Source-import qualified SMR.Source.Lexer               as Source-import qualified SMR.Codec.Peek                 as Codec-import SMR.Core.Exp                             (Decl)-import SMR.Prim.Op.Base                         (Prim)--import qualified Foreign.Marshal.Alloc          as Foreign--import qualified System.FilePath                as System-import qualified System.IO                      as System-import Control.Monad-import Data.Text                                (Text)----- | Load decls from the given file.-runLoadFileDecls :: FilePath -> IO [Decl Text Prim]-runLoadFileDecls path- -- Shimmer text source file.- | System.takeExtension path == ".smr"- = do   str     <- readFile path--        let (ts, _loc, _csRest)-                = Source.lexTokens (Source.L 1 1) str--        let config-                = Source.Config-                { Source.configReadSym  = Just-                , Source.configReadPrm  = Prim.readPrim Prim.primOpTextNames }--        case Source.parseDecls config ts of-         Left err       -> error $ show err-         Right decls    -> return decls--- -- Shimmer binary store file.- | System.takeExtension path == ".sms"- = do-        h     <- System.openBinaryFile path System.ReadMode-        nSize <- fmap fromIntegral $ System.hFileSize h-        Foreign.allocaBytes nSize $ \pBuf-         -> do  nRead <- System.hGetBuf h pBuf nSize-                when (nRead /= nSize) $ error "runConvert: short read"-                (decls, _p, _n) <- Codec.peekFileDecls pBuf nSize-                return decls-- | otherwise- = error "runLoadFileDecls: cannot load this file"
− src/SMR/CLI/Help.hs 
@@ -1,58 +0,0 @@--module SMR.CLI.Help where---helpCommands :: String-helpCommands- = unlines $- [ "  :quit,:q        Quit the REPL."- , "  :help           Show this Help page."- , "  :grammar        Show the language grammar."- , "  :prims          Show the list of available primitives."- , "  :reload,:r      Reload the current source files."- , "  :decls  NAMES?  Show named declarations, or all decls if no names given."- , "  :parse  EXP     Parse an expression and print it back."- , "  :push   EXP     Push down substitutions in an expression."- , "  :step   EXP     Single step evaluate an expression."- , "  :steps  EXP     Multi-step evaluate an expression."- , "  :trace  EXP     Multi-step evaluate an expression, showing intermediate states." ]---helpGrammar :: String-helpGrammar- = unlines $- [ "  Decl  ::= '@' Name Param* '=' Exp ';'    (Macro declaration)"- , ""- , "  Exp   ::=  Ref                           (External reference)"- , "         |   Key Exp                       (Keyword  application)"- , "         |   Exp Exp+                      (Function application)"- , "         |   Name ('^' Nat)?               (Variable with lifting specifier)"- , "         |   '\\' Param+ '.' Exp            (Function abstraction)"- , "         |   Train      '.' Exp            (Substitution train)"- , ""- , "  Ref   ::= '@' Name                       (Macro reference)"- , "         |  '%' Name                       (Symbol reference)"- , "         |  '#' Name                       (Primitive reference)"- , "         |  '?' Nat                        (Nominal reference)"- , ""- , "  Key   ::= '##tag'                        (Tag an expression)"- , "         |  '##seq'                        (Sequence evaluation)"- , "         |  '##box'                        (Box an expression, delaying evaluation)"- , "         |  '##run'                        (Run an expression, forcing  evaluation)"- , ""- , "  Param ::= Name                           (Call-by-value parameter)"- , "         |  '!' Name                       (Explicitly call-by-value parameter)"- , "         |  '~' Name                       (Explicitly call-by-name  parameter)"- , ""- , "  Train ::= Car+                           (Substitution train)"- , ""- , "  Car   ::= '['  Bind,* ']'                (Simultaneous substitution)"- , "         |  '[[' Bind,* ']]'               (Recursive substitution)"- , "         |  '{'  Bump,* '}'                (Lifting specifier)"- , ""- , "  Bind  ::= Name ('^' Nat)? '=' Exp        (Variable substitution binding)"- , "         |  '?' Nat         '=' Exp        (Nominal  substitution binding)"- , ""- , "  Bump  ::= Name ('^' Nat)? ':' Nat        (Lifting bump)"- ]-
− src/SMR/CLI/Repl.hs 
@@ -1,386 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module SMR.CLI.Repl where-import SMR.Core.Exp-import qualified SMR.CLI.Help                   as Help-import qualified SMR.CLI.Driver.Load            as Driver-import qualified SMR.Core.Step                  as Step-import qualified SMR.Core.World                 as World-import qualified SMR.Prim.Name                  as Prim-import qualified SMR.Prim.Op                    as Prim-import qualified SMR.Prim.Op.Base               as Prim-import qualified SMR.Source.Parser              as Source-import qualified SMR.Source.Lexer               as Source-import qualified SMR.Source.Pretty              as Source-import qualified SMR.Source.Expected            as Source-import qualified Data.Text.Lazy.IO              as TL-import qualified Data.Text.Lazy.Builder         as BL-import qualified System.Console.Haskeline       as HL-import qualified Data.Char                      as Char-import qualified Data.Map                       as Map-import qualified Data.Set                       as Set-import qualified Data.Text                      as Text-import Control.Monad.IO.Class-import Data.Text                                (Text)-import Data.Set                                 (Set)-import Data.Monoid-----------------------------------------------------------------------------------data Mode s p w-        = ModeNone-        | ModeParse-        | ModePush (Exp s p)-        | ModeStep (Step.Config s p w) (Exp s p)---data State s p w-        = State-        { -- | Current interpreter mode.-          stateMode     :: Mode s p w--          -- | Top-level declarations parsed from source files.-        , stateDecls    :: [Decl s p]--          -- | Working source files.-        , stateFiles    :: [FilePath]--          -- | Execution world.-        , stateWorld    :: World.World w }---type RState     = State Text Prim.Prim ()-type RConfig    = Step.Config Text Prim.Prim ()-type RWorld     = World.World  ()-type RDecl      = Decl  Text Prim.Prim-type RExp       = Exp   Text Prim.Prim-----------------------------------------------------------------------------------replStart :: RState -> IO ()-replStart state- = HL.runInputT HL.defaultSettings- $ do   HL.outputStrLn "Shimmer, version 0.1. The Lambda Machine."-        HL.outputStrLn "Type :help for help."-        replReload state----- | Main repl loop dispatcher-replLoop :: RState -> HL.InputT IO ()-replLoop state- = do   minput  <- HL.getInputLine "> "-        case minput of-         Nothing-          -> return ()--         Just input-          |  all Char.isSpace input-          -> case stateMode state of-                ModeNone        -> replLoop state-                ModePush xx     -> replPush_next state xx-                ModeStep c xx   -> replStep_next state c xx-                _               -> replLoop state--          | otherwise-          -> case words input of-                ":quit"    : []   -> replQuit    state-                ":help"    : []   -> replHelp    state-                ":reload"  : []   -> replReload  state-                ":r"       : []   -> replReload  state-                ":grammar" : []   -> replGrammar state-                ":prims"   : []   -> replPrims   state--                ":decls"   : xs-                 -> let strip ('@' : name) = name-                        strip name         = name-                    in  replDecls state-                                $ Set.fromList $ map Text.pack-                                $ map strip xs--                ":parse"   : xs   -> replParse   state (unwords xs)-                ":push"    : xs   -> replPush    state (unwords xs)-                ":step"    : xs   -> replStep    state (unwords xs)-                ":steps"   : xs   -> replSteps   state (unwords xs)-                ":trace"   : xs   -> replTrace   state (unwords xs)-                _                 -> replSteps   state input------------------------------------------------------------------------------------- | Quit the repl.-replQuit  :: RState -> HL.InputT IO ()-replQuit _state- = do   return ()------------------------------------------------------------------------------------- | Display the help page.-replHelp  :: RState -> HL.InputT IO ()-replHelp state- = do   HL.outputStr $ Help.helpCommands-        replLoop state------------------------------------------------------------------------------------- | Display the language grammar.-replGrammar  :: RState -> HL.InputT IO ()-replGrammar state- = do   HL.outputStr $ Help.helpGrammar-        replLoop state------------------------------------------------------------------------------------- | Display the list of primops.-replPrims  :: RState -> HL.InputT IO ()-replPrims state- = do   HL.outputStrLn-         $ "  name          params    description"--        HL.outputStrLn-         $ "  ----          ------    -----------"--        HL.outputStr-         $ unlines-         [ "  #unit                   unit value"-         , "  #true                   boolean true"-         , "  #false                  boolean false"-         , "  #nat'NAT                natural number"-         , "  #list                   list constructor" ]--        HL.outputStr-         $ unlines-         $ [   leftPad 16 ("  #" ++ (Text.unpack $ name))-            ++ leftPad 10  (concat [showForm f | f <- Prim.primEvalForm p])-            ++ Text.unpack (Prim.primEvalDesc p)--           | p@(Prim.PrimEval { Prim.primEvalName = Prim.PrimOp name })-                <- Prim.primEvals ]--        replLoop state--showForm :: Form -> String-showForm PVal   = "!"-showForm PExp   = "~"--leftPad :: Int -> [Char] -> [Char]-leftPad n ss- = ss ++ replicate (n - length ss) ' '------------------------------------------------------------------------------------- | Display the list of current declarations.-replDecls :: RState -> Set Name -> HL.InputT IO ()-replDecls state names- = do   liftIO  $ mapM_ (printDecl names)-                $ stateDecls state--        replLoop state---printDecl :: Set Name -> RDecl -> IO ()-printDecl names decl- | Set.null names- = do TL.putStr-         $ BL.toLazyText-         $ Source.buildDecl decl-- | DeclMac name _ <- decl- , Set.member name names- = do   TL.putStr-         $ BL.toLazyText-         $ Source.buildDecl decl-- | otherwise- = return ()------------------------------------------------------------------------------------- | Reload the current source file.-replReload :: RState -> HL.InputT IO ()-replReload state- = do-        decls   <- liftIO-                $  fmap concat $ mapM Driver.runLoadFileDecls-                $  stateFiles state--        replLoop (state-                { stateDecls    = decls })------------------------------------------------------------------------------------- | Parse and print back an expression.-replParse :: RState -> String -> HL.InputT IO ()-replParse state str- = do   result  <- liftIO $ replParseExp state str-        case result of-         Nothing-          -> replLoop state--         Just xx-          -> do liftIO  $ TL.putStrLn-                        $ BL.toLazyText-                        $ Source.buildExp Source.CtxTop xx-                HL.outputStr "\n"--                replLoop state------------------------------------------------------------------------------------- | Parse an expression and push down substitutions.-replPush :: RState -> String -> HL.InputT IO ()-replPush state str- = do   result  <- liftIO $ replParseExp state str-        case result of-         Nothing -> replLoop state-         Just xx -> replPush_next state xx----- | Advance the train pusher.-replPush_next :: RState -> RExp -> HL.InputT IO ()-replPush_next state xx- = case pushDeep xx of-        Nothing -> replLoop $ state { stateMode = ModeNone }-        Just xx'-         -> do  liftIO  $ TL.putStrLn-                        $ BL.toLazyText-                        $ Source.buildExp Source.CtxTop xx'--                replLoop $ state { stateMode = ModePush xx' }------------------------------------------------------------------------------------- | Parse an expression and single-step it.-replStep :: RState -> String -> HL.InputT IO ()-replStep state str- = replLoadExp state str replStep_next---- | Advance the single stepper.-replStep_next-        :: RState -> RConfig -> RExp-        -> HL.InputT IO ()--replStep_next state config xx- = do   erx     <- liftIO $ Step.step config (stateWorld state) xx-        case erx of-         Left Step.ResultDone-          -> replLoop $ state { stateMode = ModeNone }--         Left (Step.ResultError msg)-          -> do  HL.outputStrLn-                         $ Text.unpack-                         $ Text.pack "error: " <> msg--         Right xx'-          -> do  liftIO  $ TL.putStrLn-                         $ BL.toLazyText-                         $ Source.buildExp Source.CtxTop xx'--                 replLoop $ state { stateMode = ModeStep config xx' }------------------------------------------------------------------------------------- | Parse an expression and normalize it.-replSteps :: RState -> String -> HL.InputT IO ()-replSteps state str- = replLoadExp state str replSteps_next---- | Advance the evaluator stepper.-replSteps_next-        :: RState -> RConfig -> RExp-        -> HL.InputT IO ()--replSteps_next state config xx- = do   erx     <- liftIO $ Step.steps config (stateWorld state) xx-        case erx of-         Left msg-          -> do  HL.outputStrLn-                         $ Text.unpack-                         $ Text.pack "error: " <> msg--         Right xx'-          -> do  liftIO  $ TL.putStrLn-                         $ BL.toLazyText-                         $ Source.buildExp Source.CtxTop xx'--                 replLoop $ state { stateMode = ModeNone }------------------------------------------------------------------------------------- | Parse an expression and normalize it,---   printing out each intermediate state.-replTrace :: RState -> String -> HL.InputT IO ()-replTrace state str- = replLoadExp state str replTrace_next---- | Advance the evaluator stepper.-replTrace_next-        :: RState -> RConfig -> RExp-        -> HL.InputT IO ()--replTrace_next state config !xx0- = loop xx0- where-  loop !xx-   = do erx <- liftIO $ Step.step config (stateWorld state) xx-        case erx of-         Left (Step.ResultError msg)-          -> do  HL.outputStrLn-                  $ Text.unpack-                  $ Text.pack "error: " <> msg--         Left Step.ResultDone-          -> replLoop $ state { stateMode = ModeNone }--         Right xx'-          -> do  liftIO  $ TL.putStrLn-                         $ BL.toLazyText-                         $ Source.buildExp Source.CtxTop xx'--                 loop xx'----------------------------------------------------------------------------------replLoadExp-        :: RState -> String-        -> (RState -> RConfig -> RExp -> HL.InputT IO ())-        -> HL.InputT IO ()-replLoadExp state str eat- = do   result  <- liftIO $ replParseExp state str-        case result of-         Nothing -> replLoop state--         Just xx-          -> let-                decls   = Map.fromList-                        $ [ (n, x) | DeclMac n x <- stateDecls state ]--                prims   = Map.fromList-                        $ [ (Prim.primEvalName p, p) | p <- Prim.primEvals ]--                config  = Step.Config-                        { Step.configUnderLambdas = True-                        , Step.configHeadArgs     = True-                        , Step.configDeclsMac     = decls-                        , Step.configPrims        = prims }--              in eat state config xx-----------------------------------------------------------------------------------replParseExp :: RState -> String -> IO (Maybe RExp)-replParseExp _state str- = do   let (ts, _loc, _csRest)-                = Source.lexTokens (Source.L 1 1) str--        let config-                = Source.Config-                { Source.configReadSym  = Just-                , Source.configReadPrm  = Prim.readPrim Prim.primOpTextNames }--        case Source.parseExp config ts of-         Left err-          -> do liftIO  $ putStrLn-                        $ "parse error\n"-                        ++ Source.pprParseError err-                return Nothing--         Right xx-          -> return (Just xx)-
− src/SMR/Codec/Peek.hs 
@@ -1,486 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE BangPatterns #-}-module SMR.Codec.Peek-        ( peekFileDecls-        , peekDecl-        , peekExp,   peekKey,     peekParam-        , peekCar,   peekSnvBind, peekUpsBump-        , peekRef-        , peekName,  peekBump,    peekNom-        , peekWord8, peekWord16,  peekWord32,  peekWord64)-where-import SMR.Core.Exp-import SMR.Prim.Op.Base--import qualified Foreign.Marshal.Utils          as F-import qualified Foreign.Marshal.Alloc          as F-import qualified Foreign.Storable               as F-import qualified Foreign.Ptr                    as F--import qualified Data.Text                      as T-import qualified Data.Text.Encoding             as T-import qualified Data.ByteString.Unsafe         as BS--import Control.Monad-import Foreign.Ptr-import Data.Text                                (Text)-import Data.Bits-import Data.Word-------------------------------------------------------------------------------------------------------type Peek a = Ptr Word8 -> Int -> IO (a, Ptr Word8, Int)--------------------------------------------------------------------------------------------------------- | Peek a list of `Decl` from memory, including the SMR file header.-peekFileDecls :: Peek [Decl Text Prim]-peekFileDecls !p0 !n0- = do   (b0, p1, n1) <- peekWord8 p0 n0-        (b1, p2, n2) <- peekWord8 p1 n1-        (b2, p3, n3) <- peekWord8 p2 n2-        (b3, p4, n4) <- peekWord8 p3 n3-        when ( b0 /= 0x53 || b1 /= 0x4d || b2 /= 0x52 || b3 /= 0x31)-         $ error "peekFileDecls: bad magic"--        (ds, p5, n5) <- peekList peekDecl p4 n4-        return (ds, p5, n5)-{-# NOINLINE peekFileDecls #-}----- | Peek a `Decl` from memory.-peekDecl :: Peek (Decl Text Prim)-peekDecl !p0 !n0- = do   (b0, p1, n1) <- peekWord8 p0 n0-        p1 `seq` case b0 of-         0xa1-          -> do (tx,  p2, n2) <- peekName p1 n1-                (x,   p3, n3) <- peekExp  p2 n2-                return (DeclMac tx x, p3, n3)--         0xa2-          -> do (tx,  p2, n2) <- peekName p1 n1-                (x,   p3, n3) <- peekExp  p2 n2-                return (DeclSet tx x, p3, n3)--         _ -> error "peekDecl: invalid header"-{-# NOINLINE peekDecl #-}--------------------------------------------------------------------------------------------------------- | Peek an `Exp` from memory.-peekExp :: Peek (Exp Text Prim)-peekExp !p0 !n0- = do   (b0, p1, n1) <- peekWord8 p0 n0-        p1 `seq` case b0 of-         0xb1-          -> do (r,   p2, n2) <- peekRef p1 n1-                return  (XRef r, p2, n2)--         0xb2-          -> do (key, p2, n2) <- peekKey p1 n1-                (xx,  p3, n3) <- peekExp p2 n2-                return  (XKey key xx, p3, n3)--         0xb3-          -> do (x1,  p2, n2) <- peekExp p1 n1-                (xs,  p3, n3) <- peekList peekExp p2 n2-                return  (XApp x1 xs, p3, n3)--         0xb4-          -> do (n,   p2, n2) <- peekName p1 n1-                (i,   p3, n3) <- peekBump p2 n2-                return  (XVar n i, p3, n3)--         0xb5-          -> do (ps,  p2, n2) <- peekList peekParam p1 n1-                (x,   p3, n3) <- peekExp p2 n2-                return  (XAbs ps x, p3, n3)--         0xb6-          -> do (cs,  p2, n2) <- peekList peekCar p1 n1-                (x,   p3, n3) <- peekExp p2 n2-                return  (XSub cs x, p3, n3)--         _ -> error "peekExp: invalid header"-{-# NOINLINE peekExp #-}----- | Peek a `Key` from memory.-peekKey :: Peek Key-peekKey !p0 !n0- = do   (b0, p1, n1) <- peekWord8 p0 n0-        p1 `seq` case b0 of-         0xba   -> return (KBox, p1, n1)-         0xbb   -> return (KRun, p1, n1)-         _      -> error $ "peekKey: invalid header"-{-# INLINE peekKey #-}----- | Peek a `Param` from memory.-peekParam :: Peek Param-peekParam !p0 !n0- = do   (b0, p1, n1) <- peekWord8 p0 n0-        p1 `seq` case b0 of-         0xbc-          -> do (tx, p2, n2) <- peekName p1 n1-                return (PParam tx PVal, p2, n2)--         0xbd-          -> do (tx, p2, n2) <- peekName p1 n1-                return (PParam tx PExp, p2, n2)--         _ -> error $ "peekParam: invalid header " ++ show b0 ++ " " ++ show p1-{-# INLINE peekParam #-}----- | Peek a `Car` from memory.-peekCar :: Peek (Car Text Prim)-peekCar !p0 !n0- = do   (b0, p1, n1) <- peekWord8 p0 n0-        p1 `seq` case b0 of-         0xc1-          -> do (sbs, p2, n2) <- peekList peekSnvBind p1 n1-                return (CSim (SSnv sbs), p2, n2)--         0xc2-          -> do (sbs, p2, n2) <- peekList peekSnvBind p1 n1-                return (CRec (SSnv sbs), p2, n2)--         0xc3-          -> do (ups, p2, n2) <- peekList peekUpsBump p1 n1-                return (CUps (UUps ups), p2, n2)--         _ -> error $ "peekCar: invalid header"-{-# INLINE peekCar #-}----- | Peek an `SnvBind` from memory.-peekSnvBind :: Peek (SnvBind Text Prim)-peekSnvBind !p0 !n0- = do   (b0, p1, n1) <- peekWord8 p0 n0-        p1 `seq` case b0 of-         0xca-          -> do (n, p2, n2) <- peekName p1 n1-                (d, p3, n3) <- peekBump p2 n2-                (x, p4, n4) <- peekExp  p3 n3-                return (BindVar n d x, p4, n4)--         0xcb-          -> do (n, p2, n2) <- peekNom  p1 n1-                (x, p3, n3) <- peekExp  p2 n2-                return (BindNom n x,   p3, n3)--         _ -> error $ "peekSnvBind: invalid header"-{-# INLINE peekSnvBind #-}----- | Peek an `UpsBump` from memory.-peekUpsBump :: Peek UpsBump-peekUpsBump !p0 !n0- = do   (b0, p1, n1) <- peekWord8 p0 n0-        when (b0 /= 0xcc) $ error $ "peekUpsBump: invalid header"-        (n,  p2, n2) <- peekName  p1 n1-        (d,  p3, n3) <- peekBump  p2 n2-        (i,  p4, n4) <- peekBump  p3 n3-        return  $ (((n, d), i), p4, n4)-{-# INLINE peekUpsBump #-}--------------------------------------------------------------------------------------------------------- | Peek a `Ref` from memory.-peekRef :: Peek (Ref Text Prim)-peekRef !p0 !n0- = do   (b0, p1, n1) <- peekWord8 p0 n0-        p1 `seq` case b0 of-         0xd1-          -> do (tx, p2, n2) <- peekText p1 n1-                return (RSym tx, p2, n2)--         0xd2-          -> do (m,  p2, n2) <- peekPrim p1 n1-                return (RPrm m,  p2, n2)--         0xd3-          -> do (tx, p2, n2) <- peekText p1 n1-                return (RMac tx, p2, n2)--         0xd4-          -> do (tx, p2, n2) <- peekText p1 n1-                return (RSet tx, p2, n2)--         0xd5-          -> do (i,  p2, n2) <- peekNom  p1 n1-                return (RNom i,  p2, n2)--         _ -> error "peekRef: invalid header"-{-# INLINE peekRef #-}--------------------------------------------------------------------------------------------------------- | Peek a `Name` from memory.-peekName :: Peek Name-peekName !p !n- = do   peekText p n-{-# INLINE peekName #-}----- | Peek a `Bump` counter from memory.-peekBump :: Peek Integer-peekBump !p0 !n0- = do   (i, p1, n1) <- peekWord16 p0 n0-        return (fromIntegral i, p1, n1)-{-# INLINE peekBump #-}----- | Peek a `Nom` from memory.-peekNom :: Peek Integer-peekNom !p0 !n0- = do   (i, p1, n1) <- peekWord32 p0 n0-        return (fromIntegral i, p1, n1)-{-# INLINE peekNom #-}--------------------------------------------------------------------------------------------------------- | Peek a prim from memory.-peekPrim :: Peek Prim-peekPrim !p0 !n0- | n0 >= 1- = do   (b0, p1, n1) <- peekWord8' p0 n0-        p1 `seq` case b0 of-         0xda   -> return (PrimTagUnit,         p1, n1)-         0xdb   -> return (PrimLitBool True,    p1, n1)-         0xdc   -> return (PrimLitBool False,   p1, n1)--         0xdf-          -> do (tx, p2, n2) <- peekText p1 n1-                return  (PrimOp tx, p2, n2)--         0xef-          -> do (tx, p2, n2) <- peekText p1 n1-                case T.unpack tx of-                 "nat"-                  -> do (ls, p3, n3) <- peekList peekWord8 p2 n2-                        case ls of-                         [x0, x1, x2, x3, x4, x5, x6, x7]-                          -> do let w   =   to64 x0 `shiftL` 56-                                        .|. to64 x1 `shiftL` 48-                                        .|. to64 x2 `shiftL` 40-                                        .|. to64 x3 `shiftL` 32-                                        .|. to64 x4 `shiftL` 24-                                        .|. to64 x5 `shiftL` 16-                                        .|. to64 x6 `shiftL` 8-                                        .|. to64 x7-                                return (PrimLitNat $ fromIntegral w, p3, n3)-                         _ -> error "peekPrim: invalid payload"--                 s -> error $ "peekPrim: unknown tag " ++ show s--         _ -> error $ "peekPrim: invalid header"-- | otherwise- = error "peekPrim: invalid header"-{-# INLINE peekPrim #-}--------------------------------------------------------------------------------------------------------- | Peek a list of things from memory.-peekList :: Peek a -> Peek [a]-peekList peekA p0 n0- | n0 >= 1- = do   (b0, _p1, n1) <- peekWord8' p0 n0-        case b0 of-         0xf1-          | n1 >= 1-          -> do nElems <- fmap fromIntegral $ peek8  p0 1-                go nElems [] (F.plusPtr p0 2) (n1 - 1)--         0xf2-          | n1 >= 2-          -> do nElems <- fmap fromIntegral $ peek16 p0 1-                go nElems [] (F.plusPtr p0 3) (n1 - 2)--         0xf3-          | n1 >= 4-          -> do nElems <- fmap fromIntegral $ peek32 p0 1-                go nElems [] (F.plusPtr p0 5) (n1 - 4)--         _ -> error "peekList: invalid header"-- | otherwise- = error "peekList: invalid header"-- where  go (0 :: Int) acc p n-         = return (reverse acc, p, n)--        go i acc p n-         = do   (x, p', n') <- peekA p n-                go (i - 1) (x : acc) p' n'-        {-# NOINLINE go #-}--{-# INLINE peekList #-}--------------------------------------------------------------------------------------------------------- | Peek a text value from memory as UTF8 characters.-peekText :: Peek Text-peekText !p0 !n0- | n0 >= 1- = do   (b0, _, n1) <- peekWord8' p0 n0-        case b0 of-         0xf1-          | n1 >= 1-          -> do nBytes  <- fmap fromIntegral $ peek8 p0 1-                buf     <- F.mallocBytes nBytes-                let p2  =  F.plusPtr p0 2-                let n2  =  n0 - 2-                when (not (n2 >= nBytes)) $ error "peekText: pointer out of range"-                F.copyBytes buf p2 nBytes-                bs      <- BS.unsafePackMallocCStringLen (buf, nBytes)-                return (T.decodeUtf8 bs, F.plusPtr p2 nBytes, n2 - nBytes)--         0xf2-          -> do nBytes  <- fmap fromIntegral $ peek16 p0 1-                buf     <- F.mallocBytes nBytes-                let p2  =  F.plusPtr p0 3-                let n2  =  n0 - 3-                when (not (n2 >= nBytes)) $ error "peekText: pointer out of range"-                F.copyBytes buf p2 nBytes-                bs      <- BS.unsafePackMallocCStringLen (buf, nBytes)-                return (T.decodeUtf8 bs, F.plusPtr p2 nBytes, n2 - nBytes)--         0xf3-          -> do nBytes  <- fmap fromIntegral $ peek32 p0 1-                buf     <- F.mallocBytes nBytes-                let p2  =  F.plusPtr p0 5-                let n2  =  n0 - 5-                when (not (n2 >= nBytes)) $ error "peekText: pointer out of range"-                F.copyBytes buf p2 nBytes-                bs      <- BS.unsafePackMallocCStringLen (buf, nBytes)-                return (T.decodeUtf8 bs, F.plusPtr p2 nBytes, n2 - nBytes)--         _ -> error $ "peekText: invalid header"-- | otherwise- = error "peekText: pointer out of range"-{-# NOINLINE peekText #-}-------------------------------------------------------------------------------------------------------- | Peek a `Word8` from memory, in network byte order, with bounds check.-peekWord8  :: Peek Word8-peekWord8 p n- | n >= 1       = peekWord8' p n- | otherwise    = error "peekWord8: pointer out of bounds"-{-# NOINLINE peekWord8 #-}----- | Peek a `Word8` from memory, in network byte order, with no bounds check.-peekWord8' :: Peek Word8-peekWord8' p n- = do   w  <- F.peek p-        return (w, F.plusPtr p 1, n - 1)-{-# INLINE peekWord8' #-}----- | Peek a `Word16` from memory, in network byte order, with bounds check.-peekWord16  :: Peek Word16-peekWord16 p n- | n >= 2       = peekWord16' p n- | otherwise    = error "peekWord16: pointer out of bounds"-{-# NOINLINE peekWord16 #-}----- | Peek a `Word16` from memory, in network byte order, with no bound check.-peekWord16' :: Peek Word16-peekWord16' p n- = do   b0 <- fmap to16 $ peek8 p 0-        b1 <- fmap to16 $ peek8 p 1-        let w   =   b0 `shiftL` 8-                .|. b1-        return (w, F.plusPtr p 2, n - 2)-{-# INLINE peekWord16' #-}----- | Peek a `Word32` from memory, in network byte order, with bounds check.-peekWord32  :: Peek Word32-peekWord32 p n- | n >= 4       = peekWord32' p n- | otherwise    = error "peekWord32: pointer out of bounds"-{-# NOINLINE peekWord32 #-}----- | Peek a `Word32` from memory, in network byte order, with no bounds check.-peekWord32' :: Peek Word32-peekWord32' p n- = do   b0 <- fmap to32 $ peek8 p 0-        b1 <- fmap to32 $ peek8 p 1-        b2 <- fmap to32 $ peek8 p 2-        b3 <- fmap to32 $ peek8 p 3-        let w   =   b0 `shiftL` 24-                .|. b1 `shiftL` 16-                .|. b2 `shiftL` 8-                .|. b3-        return (w, F.plusPtr p 4, n - 4)-{-# INLINE peekWord32' #-}----- | Peek a `Word64` from memory, in network byte order, with bounds check.-peekWord64  :: Peek Word64-peekWord64 p n- | n >= 8       = peekWord64' p n- | otherwise    = error "peekWord64: pointer out of bounds"-{-# NOINLINE peekWord64 #-}----- | Peek a `Word64` from memory, in network byte order, in network byte order.-peekWord64' :: Peek Word64-peekWord64' p n- = do   b0 <- fmap to64 $ peek8 p 0-        b1 <- fmap to64 $ peek8 p 1-        b2 <- fmap to64 $ peek8 p 2-        b3 <- fmap to64 $ peek8 p 3-        b4 <- fmap to64 $ peek8 p 4-        b5 <- fmap to64 $ peek8 p 5-        b6 <- fmap to64 $ peek8 p 6-        b7 <- fmap to64 $ peek8 p 7-        let w   =   b0 `shiftL` 56-                .|. b1 `shiftL` 48-                .|. b2 `shiftL` 40-                .|. b3 `shiftL` 32-                .|. b4 `shiftL` 24-                .|. b5 `shiftL` 16-                .|. b6 `shiftL` 8-                .|. b7-        return (w, F.plusPtr p 8, n - 8)-{-# INLINE peekWord64' #-}---to16  :: Word8 -> Word16-to16 = fromIntegral-{-# INLINE to16 #-}---to64  :: Word8 -> Word64-to64 = fromIntegral-{-# INLINE to64 #-}---to32  :: Word8 -> Word32-to32 = fromIntegral-{-# INLINE to32 #-}---peek8 :: Ptr a -> Int -> IO Word8-peek8 p o = F.peekByteOff p o-{-# INLINE peek8 #-}---peek16 :: Ptr a -> Int -> IO Word16-peek16 p o = F.peekByteOff p o-{-# INLINE peek16 #-}---peek32 :: Ptr a -> Int -> IO Word32-peek32 p o = F.peekByteOff p o-{-# INLINE peek32 #-}-
− src/SMR/Codec/Poke.hs 
@@ -1,324 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DoAndIfThenElse #-}-module SMR.Codec.Poke-        ( pokeFileDecls-        , pokeDecl-        , pokeExp,   pokeKey,      pokeParam-        , pokeCar,   pokeSnvBind,  pokeUpsBump-        , pokeRef-        , pokeName,  pokeBump,     pokeNom-        , pokeWord8, pokeWord16,   pokeWord32,  pokeWord64)-where-import SMR.Core.Exp-import SMR.Prim.Op.Base--import qualified Foreign.Marshal.Utils          as F-import qualified Foreign.Storable               as F-import qualified Foreign.Ptr                    as F--import qualified Data.Text                      as T-import qualified Data.Text.Encoding             as T-import qualified Data.ByteString.Unsafe         as BS--import Data.Text                                (Text)-import Foreign.Ptr                              (Ptr)-import Control.Monad-import Data.Bits-import Data.Word-------------------------------------------------------------------------------------------------------type Poke a = a -> Ptr Word8 -> IO (Ptr Word8)--------------------------------------------------------------------------------------------------------- | Poke a list of `Decl` into memory, including the SMR file header.-pokeFileDecls :: Poke [Decl Text Prim]-pokeFileDecls ds-        =   pokeWord8 0x53              -- 'S'-        >=> pokeWord8 0x4d              -- 'M'-        >=> pokeWord8 0x52              -- 'R'-        >=> pokeWord8 0x31              -- '1'-        >=> pokeList  pokeDecl ds-{-# NOINLINE pokeFileDecls #-}----- | Poke a `Decl` into memory.-pokeDecl :: Poke (Decl Text Prim)-pokeDecl xx- = case xx of-        DeclMac name x-         ->     pokeWord8 0xa1 >=> pokeText name >=> pokeExp x--        DeclSet name x-         ->     pokeWord8 0xa2 >=> pokeText name >=> pokeExp x-{-# NOINLINE pokeDecl #-}--------------------------------------------------------------------------------------------------------- | Poke an `Exp` into memory.-pokeExp :: Poke (Exp Text Prim)-pokeExp xx- = case xx of-        XRef ref-         ->     pokeWord8 0xb1 >=> pokeRef ref--        XKey key x-         ->     pokeWord8 0xb2 >=> pokeKey key >=> pokeExp x--        XApp x1 xs-         ->     pokeWord8 0xb3 >=> pokeExp x1  >=> pokeList pokeExp xs--        XVar name i-         ->     pokeWord8 0xb4 >=> pokeName name >=> pokeBump i--        XAbs ps x-         ->     pokeWord8 0xb5 >=> pokeList pokeParam ps >=> pokeExp x--        XSub cs x-         ->     pokeWord8 0xb6 >=> pokeList pokeCar cs >=> pokeExp x-{-# NOINLINE pokeExp #-}----- | Poke a `Key` into memory.-pokeKey :: Poke Key-pokeKey key- = case key of-        KBox -> pokeWord8 0xba-        KRun -> pokeWord8 0xbb-{-# INLINE pokeKey #-}----- | Poke a `Param` into memory.-pokeParam :: Poke Param-pokeParam pp- = case pp of-        PParam tx PVal-         ->     pokeWord8 0xbc >=> pokeName tx--        PParam tx PExp-         ->     pokeWord8 0xbd >=> pokeName tx-{-# INLINE pokeParam #-}----- | Poke a `Car` into memory.-pokeCar :: Poke (Car Text Prim)-pokeCar car- = case car of-        CSim (SSnv sbs)-         ->     pokeWord8 0xc1 >=> pokeList pokeSnvBind sbs--        CRec (SSnv sbs)-         ->     pokeWord8 0xc2 >=> pokeList pokeSnvBind sbs--        CUps (UUps ups)-         ->     pokeWord8 0xc3 >=> pokeList pokeUpsBump ups-{-# INLINE pokeCar #-}----- | Poke an `SnvBind` into memory.-pokeSnvBind :: Poke (SnvBind Text Prim)-pokeSnvBind !b- = case b of-        BindVar n d x-         -> pokeWord8 0xca >=> pokeName n >=> pokeBump d >=> pokeExp x--        BindNom n x-         -> pokeWord8 0xcb >=> pokeNom  n >=> pokeExp x-{-# INLINE pokeSnvBind #-}----- | Poke an `UpsBump` into memory.-pokeUpsBump :: Poke UpsBump-pokeUpsBump ((n, d), i)- =      pokeWord8 0xcc >=> pokeName n >=> pokeBump d >=> pokeBump i-{-# INLINE pokeUpsBump #-}--------------------------------------------------------------------------------------------------------- | Poke a `Ref` into memory.-pokeRef :: Poke (Ref Text Prim)-pokeRef !r- = case r of-        RSym tx -> pokeWord8 0xd1 >=> pokeName tx-        RPrm p  -> pokeWord8 0xd2 >=> pokePrim p-        RMac tx -> pokeWord8 0xd3 >=> pokeName tx-        RSet tx -> pokeWord8 0xd4 >=> pokeName tx-        RNom i  -> pokeWord8 0xd5 >=> pokeNom  i-{-# INLINE pokeRef #-}--------------------------------------------------------------------------------------------------------- | Peek a `Name` from memory.-pokeName :: Poke Name-pokeName !p n- =      pokeText p n-{-# INLINE pokeName #-}----- | Poke a `Bump` into memory.-pokeBump :: Poke Integer-pokeBump !n !p- = if n <= 2^(16 :: Int) then-    do  pokeWord16 (fromIntegral n) p-   else error "shimmer.pokeBump: bump counter too large."-{-# NOINLINE pokeBump #-}----- | Poke a `Nom` into memory.-pokeNom  :: Poke Integer-pokeNom !n !p- = if n <= 2^(28 :: Int) then-    do  pokeWord32 (fromIntegral n) p-   else error "shimmer.pokeNom: nominal constant index too large."-{-# NOINLINE pokeNom #-}--------------------------------------------------------------------------------------------------------- | Poke a prim into memory.-pokePrim :: Poke Prim-pokePrim !pp- = case pp of-        PrimTagUnit             -> pokeWord8 0xda-        PrimLitBool True        -> pokeWord8 0xdb-        PrimLitBool False       -> pokeWord8 0xdc-        PrimOp tx               -> pokeWord8 0xdf >=> pokeText tx--        -- Integers are currently squashed into Word64s.-        PrimLitNat n-         -> pokeWord8 0xef-                >=> pokeName (T.pack "nat")-                >=> pokeList pokeWord8-                        [ fromIntegral $ (n .&. 0xff00000000000000) `shiftR` 56-                        , fromIntegral $ (n .&. 0x00ff000000000000) `shiftR` 48-                        , fromIntegral $ (n .&. 0x0000ff0000000000) `shiftR` 40-                        , fromIntegral $ (n .&. 0x000000ff00000000) `shiftR` 32-                        , fromIntegral $ (n .&. 0x00000000ff000000) `shiftR` 24-                        , fromIntegral $ (n .&. 0x0000000000ff0000) `shiftR` 16-                        , fromIntegral $ (n .&. 0x000000000000ff00) `shiftR` 8-                        , fromIntegral $ (n .&. 0x00000000000000ff)]--        PrimTagList{} -> error "TODO: pokePrim: handle lists"-{-# INLINE pokePrim #-}--------------------------------------------------------------------------------------------------------- | Poke a list of things into memory, including size info.-pokeList :: Poke a -> Poke [a]-pokeList pokeA ls- = do   let  n     = length ls-        if n <= 2^(8 :: Int) - 1-         then   pokeWord8 0xf1 >=> pokeWord8  (fromIntegral n) >=> go ls--        else if n <= 2^(16 :: Int) - 1-         then   pokeWord8 0xf2 >=> pokeWord16 (fromIntegral n) >=> go ls--        else if n <= 2^(28 :: Int)-         then   pokeWord8 0xf2 >=> pokeWord32 (fromIntegral n) >=> go ls--        else error "shimmer.pokeList: list too long."-- where  go [] !p0 = return p0-        go (x : xs) !p0-         = do   p1 <- pokeA x p0-                go xs p1-        {-# NOINLINE go #-}--{-# INLINE pokeList #-}--------------------------------------------------------------------------------------------------------- | Poke a text value into memory as UTF8 characters.-pokeText :: Poke Text-pokeText !tx !p0- = do   let bs = T.encodeUtf8 tx--        BS.unsafeUseAsCStringLen bs $ \(pStr, nBytes)-         -> if nBytes <= 255 then-             do p1 <- pokeWord8 0xf1 p0-                p2 <- pokeWord8 (fromIntegral nBytes) p1-                F.copyBytes (F.castPtr p2) pStr nBytes-                return (F.plusPtr p2 nBytes)--            else if nBytes <= 65535 then-             do p1 <- pokeWord8  0xf2 p0-                p2 <- pokeWord16 (fromIntegral nBytes) p1-                F.copyBytes (F.castPtr p2) pStr nBytes-                return (F.plusPtr p2 nBytes)--            -- The Haskell Int type is only guaranteed to have at least 29-            -- bits of precision. We just limit the string size to 2^28,-            -- as 256MB should be enough for any sort of program text.-            else if nBytes <= 2^(28 :: Int) then-             do p1 <- pokeWord8  0xf3 p0-                p2 <- pokeWord32 (fromIntegral nBytes) p1-                F.copyBytes (F.castPtr p2) pStr nBytes-                return (F.plusPtr p2 nBytes)--            else error "shimmer.pokeText: text string too large."-{-# NOINLINE pokeText #-}--------------------------------------------------------------------------------------------------------- | Poke a `Word8` into memory.-pokeWord8 :: Poke Word8-pokeWord8 w p- = do   F.poke p w-        return (F.plusPtr p 1)-{-# INLINE pokeWord8 #-}----- | Poke a `Word16` into memory, in network byte order.-pokeWord16 :: Poke Word16-pokeWord16 w p- = do   poke8 p 0 $ from16 $ (w .&. 0xff00) `shiftR` 8-        poke8 p 1 $ from16 $ (w .&. 0x00ff)-        return (F.plusPtr p 2)-{-# INLINE pokeWord16 #-}----- | Poke a `Word32` into memory, in network byte order.-pokeWord32 :: Poke Word32-pokeWord32 w p- = do   poke8 p 0 $ from32 $ (w .&. 0xff000000) `shiftR` 24-        poke8 p 1 $ from32 $ (w .&. 0x00ff0000) `shiftR` 16-        poke8 p 2 $ from32 $ (w .&. 0x0000ff00) `shiftR`  8-        poke8 p 3 $ from32 $ (w .&. 0x000000ff)-        return (F.plusPtr p 4)-{-# INLINE pokeWord32 #-}----- | Poke a `Word64` into memory, in network byte order.-pokeWord64 :: Poke Word64-pokeWord64 w p- = do   poke8 p 0 $ from64 $ (w .&. 0xff00000000000000) `shiftR` 56-        poke8 p 1 $ from64 $ (w .&. 0x00ff000000000000) `shiftR` 48-        poke8 p 2 $ from64 $ (w .&. 0x0000ff0000000000) `shiftR` 40-        poke8 p 3 $ from64 $ (w .&. 0x000000ff00000000) `shiftR` 32-        poke8 p 4 $ from64 $ (w .&. 0x00000000ff000000) `shiftR` 24-        poke8 p 5 $ from64 $ (w .&. 0x0000000000ff0000) `shiftR` 16-        poke8 p 6 $ from64 $ (w .&. 0x000000000000ff00) `shiftR`  8-        poke8 p 7 $ from64 $ (w .&. 0x00000000000000ff)-        return (F.plusPtr p 8)-{-# INLINE pokeWord64 #-}---from16 :: Word16 -> Word8-from16 = fromIntegral-{-# INLINE from16 #-}---from32 :: Word32 -> Word8-from32 = fromIntegral-{-# INLINE from32 #-}---from64 :: Word64 -> Word8-from64 = fromIntegral-{-# INLINE from64 #-}---poke8 :: Ptr a -> Int -> Word8 -> IO ()-poke8 p i w = F.pokeByteOff p i w-{-# INLINE poke8 #-}-
− src/SMR/Codec/Size.hs 
@@ -1,132 +0,0 @@--module SMR.Codec.Size-        ( sizeOfSeq-        , sizeOfFile, sizeOfDecl-        , sizeOfRef-        , sizeOfExp,  sizeOfParam-        , sizeOfCar,  sizeOfSnvBind, sizeOfUpsBump-        , sizeOfName, sizeOfBump,    sizeOfNom)-where-import SMR.Core.Exp-import SMR.Prim.Op.Base-import qualified Data.Text.Foreign      as T-import qualified Data.Text              as T--------------------------------------------------------------------------------------------------------- | Compute the size of a serialized shimmer file containing the given decls.-sizeOfFile :: [Decl Text Prim] -> Int-sizeOfFile decls- = 4 + sizeOfSeq sizeOfDecl decls----- | Compute the serialized size of a given declaration.-sizeOfDecl :: Decl Text Prim -> Int-sizeOfDecl dd- = case dd of-        DeclMac n x     -> 1 + sizeOfName n + sizeOfExp x-        DeclSet n x     -> 1 + sizeOfName n + sizeOfExp x--------------------------------------------------------------------------------------------------------- | Compute the serialized size of the given expression.-sizeOfExp :: Exp Text Prim -> Int-sizeOfExp xx- = case xx of-        XRef ref        -> 1 + sizeOfRef ref-        XKey _key x     -> 2 + sizeOfExp x-        XApp x1 xs      -> 1 + sizeOfExp x1 + sizeOfSeq sizeOfExp xs-        XVar n b        -> 1 + sizeOfName n + sizeOfBump b-        XAbs ps x       -> 1 + sizeOfSeq sizeOfParam ps + sizeOfExp x-        XSub cs x       -> 1 + sizeOfSeq sizeOfCar cs   + sizeOfExp x----- | Compute the serialized size of a parameter.-sizeOfParam :: Param -> Int-sizeOfParam (PParam n _form)- = 1 + sizeOfName n----- | Compute the serialized size of a substitution car.-sizeOfCar :: Car Text Prim -> Int-sizeOfCar cc- = case cc of-        CSim (SSnv snv) -> 1 + sizeOfSeq sizeOfSnvBind snv-        CRec (SSnv snv) -> 1 + sizeOfSeq sizeOfSnvBind snv-        CUps (UUps ups) -> 1 + sizeOfSeq sizeOfUpsBump ups----- | Compute the serialized size of a substitution bind.-sizeOfSnvBind :: SnvBind Text Prim -> Int-sizeOfSnvBind sb- = case sb of-        BindVar n i x   -> 1 + sizeOfName n + sizeOfBump i + sizeOfExp x-        BindNom i x     -> 1 + sizeOfBump i + sizeOfExp x----- | Compute the serialized size of an lifting bump.-sizeOfUpsBump :: UpsBump -> Int-sizeOfUpsBump ub- = case ub of-        ((n, d), i)     -> 1 + sizeOfName n + sizeOfBump d + sizeOfBump i--------------------------------------------------------------------------------------------------------- | Compute the serialized size of the given reference.-sizeOfRef :: Ref Text Prim -> Int-sizeOfRef rr- = case rr of-        RSym n          -> 1 + sizeOfName n-        RPrm p          -> 1 + sizeOfPrim p-        RMac n          -> 1 + sizeOfName n-        RSet n          -> 1 + sizeOfName n-        RNom n          -> 1 + sizeOfNom  n---sizeOfPrim :: Prim -> Int-sizeOfPrim pp- = case pp of-        PrimTagUnit     -> 1-        PrimLitBool _   -> 1-        PrimOp tx       -> 1 + sizeOfName tx--        PrimLitNat _    -> 1 + sizeOfName (T.pack "nat")-                        +  sizeOfSeq (const 1) (replicate (8 :: Int) (0 :: Int))--        _               -> error "TODO: handle lists"--------------------------------------------------------------------------------------------------------- | Compute the serialized size of a text string.-sizeOfName :: Text -> Int-sizeOfName tt- = result- where  n       = T.lengthWord16 tt-        result-         | n < 2^(8  :: Int) = 1 + 1 + n-         | n < 2^(16 :: Int) = 1 + 2 + n-         | n < 2^(32 :: Int) = 1 + 4 + n-         | otherwise         = error "shimmer.sizeOfName: name too long to serialize."----- | Compute the serialized size of a bump bounter.-sizeOfBump :: Integer -> Int-sizeOfBump _ = 2----- | Compute the serialized size of a nominal atom.-sizeOfNom  :: Integer -> Int-sizeOfNom _  = 4----- | Compute the serialized size of a sequence of things.-sizeOfSeq :: (a -> Int) -> [a] -> Int-sizeOfSeq fs xs- = result- where  n       = length xs-        result-         | n < 2^(8  :: Int) = 1 + 1 + sum (map fs xs)-         | n < 2^(16 :: Int) = 1 + 2 + sum (map fs xs)-         | n < 2^(32 :: Int) = 1 + 4 + sum (map fs xs)-         | otherwise         = error "shimmer.sizeOfSeq: sequence too long to serialize."-
− src/SMR/Core/Exp.hs 
@@ -1,38 +0,0 @@--module SMR.Core.Exp-        ( -- * Abstract Syntax-          Decl  (..)-        , Exp   (..)-        , Param (..)-        , Form  (..)-        , Key   (..)-        , Train-        , Car   (..)-        , Snv   (..), SnvBind(..)-        , Ups   (..), UpsBump-        , Ref   (..)-        , Name, Nom, Depth, Bump-        , Text--         -- * Compounds-        , makeXApps, takeXApps-        , makeXAbs-        , nameOfParam, formOfParam--         -- * Substitution Trains-        , trainCons-        , trainAppend-        , trainApply-        , snvApply-        , snvOfNamesArgs--        -- * Substitution Pushing-        , pushHead-        , pushDeep)-where-import SMR.Core.Exp.Base-import SMR.Core.Exp.Compounds-import SMR.Core.Exp.Train-import SMR.Core.Exp.Push-import Data.Text                (Text)-
− src/SMR/Core/Exp/Base.hs 
@@ -1,143 +0,0 @@-{-# LANGUAGE BangPatterns #-}--- | The Shimmer Abstract Syntax Tree (AST)-module SMR.Core.Exp.Base where-import Data.Text                (Text)----- | Top-level declaration,---   parameterised by the types of symbols and primitives.-data Decl s p-        = DeclMac Name (Exp s p)-        | DeclSet Name (Exp s p)-        deriving Show----- | Expression,---   parameterised by the types of symbols and primitives-data Exp s p-        -- | Reference to an external thing.-        = XRef  !(Ref s p)--        -- | Keyed expressions.-        | XKey  !Key !(Exp s p)--        -- | Application of a function expression to an argument.-        | XApp  !(Exp s p) ![Exp s p]--        -- | Variable name with a depth counter.-        | XVar  !Name !Depth--        -- | Abstraction with a list of parameters and a body expression.-        | XAbs  ![Param] !(Exp s p)--        -- | Substitution train applied to an expression.-        --   The train car at the head of the list is applied first.-        | XSub  !(Train s p) !(Exp s p)-        deriving Show----- | Substitution train.-type Train s p-        = [Car s p]----- | Function parameter.-data Param-        = PParam !Name !Form-        deriving Show----- | Form of argument required in application.-data Form-        -- | Value for call-by-value.-        = PVal--        -- | Expression for call-by-name-        | PExp-        deriving Show----- | Expression keys (super primitives)-data Key-        -- | Delay evaluation of an expression used as the argument-        --   of a call-by-value function application.-        = KBox--        -- | Run a boxed expression.-        | KRun--        deriving Show----- | A car on the substitution train,---   parameterised by the types used for symbols and primitives.-data Car s p-        -- | Simultaneous subsitution.-        = CSim  !(Snv s p)--        -- | Recursive substitution.-        | CRec  !(Snv s p)--        -- | Lifting.-        | CUps  !Ups-        deriving Show----- | Explicit substitution map,---   parameterised by the types used for symbols and primitives.-data Snv s p-        = SSnv ![SnvBind s p]-        deriving Show--data SnvBind s p-        = BindVar !Name !Depth !(Exp s p)-        | BindNom !Nom         !(Exp s p)-        deriving Show----- | Lifting indicator,---   mapping name and binding depth to number of levels to lift.-data Ups-        = UUps ![UpsBump]-        deriving Show----- | Indicates how to bump the index on a variable.-type UpsBump-        = ((Name, Depth), Bump)----- | Binding depth indicator.-type Depth = Integer----- | Bump index indicator.-type Bump  = Integer----- | A reference to some external thing.-data Ref s p-        -- | An uninterpreted symbol.-        = RSym  !s--        -- | A primitive value.-        | RPrm  !p--        -- | A macro name.-        | RMac  !Name--        -- | A set name.-        | RSet  !Name--        -- | A nominal variable.-        | RNom  !Nom-        deriving Show----- | Generic names for things.-type Name = Text----- | Index of a nominal constant.-type Nom = Integer-
− src/SMR/Core/Exp/Compounds.hs 
@@ -1,50 +0,0 @@--module SMR.Core.Exp.Compounds where-import SMR.Core.Exp.Base----- Apps -------------------------------------------------------------------------- | Make an application of a function to the given list of arguments,---   suppressing the application of there are no arguments.-makeXApps :: Exp s p -> [Exp s p] -> Exp s p-makeXApps xFun []       = xFun-makeXApps xFun xsArgs   = XApp xFun xsArgs----- | Take an application of a function to a list of arguments.---   TODO(BL): fix rubbish list append complexity.-takeXApps :: Exp s p -> Maybe (Exp s p, [Exp s p])-takeXApps xx- = case xx of-        XApp x1@(XApp _ _) x2-          -> case takeXApps x1 of-                Just (f1, xs1) -> Just (f1, xs1 ++ x2)-                Nothing        -> Nothing--        XApp x1 x2-          -> Just (x1, x2)--        _ -> Nothing----- Abs --------------------------------------------------------------------------- | Make an abstraction,---   short circuiting to the body if there are no parameters.-makeXAbs :: [Param] -> Exp s p -> Exp s p-makeXAbs [] xBody = xBody-makeXAbs ps xBody = XAbs ps xBody----- Param ------------------------------------------------------------------------- | Get the name of a function parameter.-nameOfParam :: Param -> Name-nameOfParam p- = case p of-        PParam n  _     -> n----- | Get the argument form required by a parameter.-formOfParam :: Param -> Form-formOfParam p- = case p of-        PParam _ f      -> f
− src/SMR/Core/Exp/Push.hs 
@@ -1,104 +0,0 @@--module SMR.Core.Exp.Push where-import SMR.Core.Exp.Train-import SMR.Core.Exp.Compounds-import SMR.Core.Exp.Base----- | Push down any outermost substitution train to reveal the head constructor.-pushHead :: Exp s p -> Maybe (Exp s p)-pushHead xx- = case xx of-        XRef _          -> Nothing-        XVar _ _        -> Nothing-        XAbs _ _        -> Nothing-        XApp _ _        -> Nothing-        XSub cs2 x2     -> pushTrain cs2 x2-        XKey _ _        -> Nothing----- | Push down the left-most substitution train in an expression,---   or 'Nothing' if there isn't one.-pushDeep :: Exp s p -> Maybe (Exp s p)-pushDeep xx- = case xx of-        XRef _          -> Nothing-        XVar _ _        -> Nothing--        XKey k1 x2-         | Just x2'     <- pushDeep x2-         -> Just $ XKey k1 x2'--         | otherwise    -> Nothing--        XApp x1 xs2-         |  Just x1'    <- pushDeep x1-         -> Just $ XApp x1' xs2--         |  Just xs2'   <- pushDeepFirst xs2-         -> Just $ XApp x1 xs2'--         |  otherwise   -> Nothing---        XAbs ns x-         -> case pushDeep x of-                Nothing -> Nothing-                Just x' -> Just (XAbs ns x')--        XSub cs1 x2     -> pushTrain cs1 x2----- | Push down the first substiution train in the given list.-pushDeepFirst :: [Exp s p] -> Maybe [Exp s p]-pushDeepFirst [] = Nothing-pushDeepFirst (x : xs)- = case pushDeep x of-        Nothing-         |  Just xs'    <- pushDeepFirst xs-         -> Just (x : xs')-         | otherwise    -> Nothing--        Just x'-         -> Just (x' : xs)----- | Push a substitution train down into an expression to reveal---   the head constructor.-pushTrain :: [Car s p] -> Exp s p -> Maybe (Exp s p)-pushTrain cs1 x2- = case x2 of-        -- Unfold macro under a substitution.-        -- Macro and symbol bodies are closed,-        -- so we can drop the substitution.-        XRef (RMac _)   -> Just x2-        XRef (RSym _)   -> Just x2-        XRef (RPrm _)   -> Just x2-        XRef (RNom _)   -> Just x2--        -- Reference to some other thing.-        XRef _          -> Nothing--        -- Apply the train to a variable.-        XVar name depth-         -> Just $ trainApplyVar cs1 name depth--        -- Push train under key.-        XKey k21 x22-         -> Just $ XKey k21 (trainApply cs1 x22)--        -- Push train into both sides of an application.-        XApp x21 x22-         -> Just $ XApp (trainApply cs1 x21) (map (trainApply cs1) x22)--        -- Push train under abstraction.-        XAbs ps21 x22-         -> let ns21    = map nameOfParam ps21-                cs1'    = trainBump ns21 cs1-            in  Just $ XAbs ps21 (trainApply cs1' x22)--        -- Combine trains.-        XSub cs2 x22-         -> Just $ trainApply (cs2 ++ cs1) x22--
− src/SMR/Core/Exp/Train.hs 
@@ -1,279 +0,0 @@-{-# LANGUAGE ParallelListComp #-}-module SMR.Core.Exp.Train where-import SMR.Core.Exp.Base-import Data.Maybe----- Train ------------------------------------------------------------------------- | Cons a car on the front of an existing train.------   If the new car is empty it will be suppressed.------   If the new car can be combined with the first car on the existing---   train then it will be combined.----trainCons :: Car s p -> [Car s p] -> [Car s p]-trainCons c1 cs2- | carIsEmpty c1 = cs2- | otherwise- = case cs2 of-        []-         -> c1 : []--        c2 : cs2'-         |  CUps ups1   <- c1-         ,  CUps ups2   <- c2-         -> CUps (upsCombine ups1 ups2) : cs2'--         |  otherwise-         -> c1 : cs2----- | Append two trains.-trainAppend :: [Car s p] -> [Car s p] -> [Car s p]-trainAppend ccA ccB- = case ccA of-        []        -> ccB-        cA : csA  -> trainAppend' cA csA ccB- where-        trainAppend' c1 cs1 cc2-         = case cs1 of-                -- Combine the  state with the first car on the second train.-                []-                 -> trainCons c1 cc2--                -- Walk over the first train, combining ups's as we go.-                c1' : cs1'-                 |  CUps ups1  <- c1-                 ,  CUps ups1' <- c1'-                 -> trainAppend' (CUps (upsCombine ups1 ups1')) cs1' cc2--                 |  otherwise-                 -> c1 : (trainAppend' c1' cs1' cc2)----- | Bump a train due to pushing it under an abstraction with the---   given parameter names.-trainBump :: [Name] -> [Car s p] -> [Car s p]-trainBump ns cs- = case cs of-        []     -> []--        CSim snv : cs'-         -> trainCons (CSim (snvBump ns snv)) $ trainBump ns cs'--        CRec snv : cs'-         -> trainCons (CRec (snvBump ns snv)) $ trainBump ns cs'--        CUps ups : cs'-         -> trainCons (CUps (upsBump ns ups)) $ trainBump ns cs'----- | Wrap an expression in a substitution train.---   If the expression is a plain-trainApply :: [Car s p] -> Exp s p -> Exp s p-trainApply cs1 xx- | []  <- cs1- = xx-- | otherwise- = case xx of-        XRef (RMac _)   -> xx-        XRef (RSym _)   -> xx-        XRef (RPrm _)   -> xx-        XRef (RNom ix)  -> trainApplyNom cs1 ix-        XVar name depth -> trainApplyVar cs1 name depth-        XSub cs2  x2    -> trainApply (trainAppend cs2 cs1) x2-        _               -> XSub cs1 xx----- | Apply a train to a named variable of a given name and depth.-trainApplyVar :: [Car s p] -> Name -> Integer -> Exp s p-trainApplyVar cs name depth- = case cs of-        []              -> XVar name depth-        CSim snv : cs'  -> trainApply cs' (snvApplyVar False snv name depth)-        CRec snv : cs'  -> trainApply cs' (snvApplyVar True  snv name depth)-        CUps ups : cs'  -> trainApply cs' (upsApplyVar ups name depth)----- | Apply a train to a nominal variable of a given index.-trainApplyNom :: [Car s p] -> Integer -> Exp s p-trainApplyNom cs ix- = case cs of-        []              -> XRef (RNom ix)-        CSim snv  : cs' -> trainApply cs' (snvApplyNom  False snv ix)-        CRec snv  : cs' -> trainApply cs' (snvApplyNom  True  snv ix)-        CUps _ups : cs' -> trainApply cs' (XRef (RNom ix))----- Car --------------------------------------------------------------------------- | Check if a substitution car is empty.-carIsEmpty :: Car s p -> Bool-carIsEmpty c- = case c of-        CSim snv -> snvIsEmpty snv-        CRec snv -> snvIsEmpty snv-        CUps ups -> upsIsEmpty ups----- Snv --------------------------------------------------------------------------- | Build a substitution from lists of names and arguments.-snvOfNamesArgs :: [Name] -> [Exp s p] -> Snv s p-snvOfNamesArgs ns xs- = SSnv [BindVar n 0 x | n <- ns | x <- xs]----- | Check if the given substitution is empty.-snvIsEmpty :: Snv s p -> Bool-snvIsEmpty (SSnv bs)- = case bs of-        []      -> True-        _       -> False----- | Bump a substitution due to pushing it under an abstraction with---   the given parameter names.-snvBump :: [Name] -> Snv s p -> Snv s p-snvBump ns (SSnv ts)- = SSnv $ mapMaybe (snvBump1 ns) ts- where-        snvBump1 names (BindVar name depth x)-         = Just $ BindVar name-                (depth + (if elem name names then 1 else 0))-                (upsApply (UUps (map (\name' -> ((name', 0), 1)) names)) x)--        snvBump1 names (BindNom ix x)-         = Just $ BindNom ix-                (upsApply (UUps (map (\name' -> ((name', 0), 1)) names)) x)----- | Wrap a train consisting of a single simultaneous substitution---   around an expression.-snvApply :: Bool -> Snv s p -> Exp s p -> Exp s p-snvApply isRec snv@(SSnv bs) xx- = case bs of-        []        -> xx-        _ | isRec -> trainApply (CRec snv : []) xx-        _         -> trainApply (CSim snv : []) xx----- | Apply a substitution to a variable of a given name and depth.-snvApplyVar :: Bool -> Snv s p -> Name -> Integer -> Exp s p-snvApplyVar isRec snv@(SSnv bs) name depth- = case bs of-        []-         -> XVar name depth--        BindVar name' depth' x' : bs'-         |  name  == name'-         ,  depth == depth'-         -> if isRec then XSub (CRec snv : []) x'-                     else x'--         |  name   == name'-         ,  depth  >  depth'-         -> XVar name (depth - 1)--         |  otherwise-         -> snvApplyVar isRec (SSnv bs') name depth--        BindNom{} : bs'-         -> snvApplyVar isRec (SSnv bs') name depth----- | Apply a substitution to a nominal variable of the given index.-snvApplyNom :: Bool -> Snv s p -> Integer -> Exp s p-snvApplyNom isRec snv@(SSnv bs) ix- = case bs of-        []-         -> XRef (RNom ix)--        BindVar{} : bs'-         -> snvApplyNom isRec (SSnv bs') ix--        BindNom ix' x' : bs'-         |  ix == ix'-         -> if isRec then XSub (CRec snv : []) x'-                     else x'--         | otherwise-         -> snvApplyNom isRec (SSnv bs') ix----- Ups --------------------------------------------------------------------------- | Check if the given ups is empty.-upsIsEmpty :: Ups -> Bool-upsIsEmpty (UUps bs)- = case bs of-        []      -> True-        _       -> False----- | Wrap an expression in a train consisting of a single ups.-upsApply :: Ups -> Exp s p -> Exp s p-upsApply ups@(UUps us) xx- = case us of-        []      -> xx-        _       -> trainApply ((CUps ups) : []) xx----- | Apply an ups to a variable.-upsApplyVar :: Ups -> Name -> Integer -> Exp s n-upsApplyVar (UUps bs) name ix- = case bs of-        []-         -> XVar name ix--        ((name', depth'), inc') : bs'-         |  name   == name'-         ,  depth' <= ix-         -> upsApplyVar (UUps bs') name (ix + inc')--         |  otherwise-         -> upsApplyVar (UUps bs') name ix----- | Bump ups (substitution lifting) due to pushing it---   under an absraction with the given named binders.-upsBump :: [Name] -> Ups -> Ups-upsBump ns0 (UUps bs)- = UUps $ mapMaybe (upsBump1 ns0) bs- where-        upsBump1 ns l-         | ((n, d), inc) <- l-         , elem n ns-         = Just ((n, d + 1), inc)--         | otherwise-         = Just l----- | Combine two lists of ups.-upsCombine :: Ups -> Ups -> Ups-upsCombine (UUps ts1) (UUps ts2)- = UUps (foldr upsCombineBump ts2 ts1)----- | Combine a bump with an existing list of them.---   Applying the result to an expression will achieve the same result as---   applying the whole list and then the extra one.-upsCombineBump :: UpsBump -> [UpsBump] -> [UpsBump]-upsCombineBump b bs- | ((name, depth), inc) <- b- = case bs of-        -- We cannot combine the new bump with anything else,-        -- so add it to the end of the list.-        []-         -> [b]--        b'@((name', depth'), inc') : bs'-         -- Combine the new bump with an existing one of the same name.-         |  name  == name'-         ,  depth == depth'-         -> ((name, depth'), inc + inc') : bs'--         -- Try to combine the new bump with the tail of the list.-         |  otherwise-         -> b' : (upsCombineBump b bs')-
− src/SMR/Core/Step.hs 
@@ -1,349 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module SMR.Core.Step-        ( Config        (..)-        , Result        (..)-        , steps-        , step)-where-import SMR.Core.Exp-import SMR.Core.World-import SMR.Prim.Op.Base-import Data.Text                (Text)-import Data.Map                 (Map)-import qualified Data.Map       as Map-------------------------------------------------------------------------------------- | Evaluation config-data Config s p w-        = Config-        { -- | Reduce under lambda abstractions.-          configUnderLambdas    :: !Bool--          -- | Reduce arguments when head is not an abstraction.-        , configHeadArgs        :: !Bool--          -- | Primitive operator declarations.-        , configPrims           :: !(Map p (PrimEval s p w))--          -- | Macro declarations.-        , configDeclsMac        :: !(Map Name (Exp s p)) }----- | Result of evaluation.-data Result-        = ResultDone-        | ResultError   Text-        deriving Show------------------------------------------------------------------------------------- | Multi-step reduction to normal form.-steps   :: (Ord p, Show p)-        => Config s p w-        -> World w -> Exp s p-        -> IO (Either Text (Exp s p))--steps !config !world !xx- = do   erx <- step config world xx-        case erx of-         Left ResultDone         -> return $ Right xx-         Left (ResultError err)  -> return $ Left err-         Right xx'               -> steps config world xx'------------------------------------------------------------------------------------- | Single step reduction.------   This is a definitional interpreter, intended to be easy to understand---   and get right, but not fast. Each time we take a step we decend into---   the AST looking for the next redex, which causes evaluation to have---   a higher asymptotic complexity than it would with an evaluator that---   that manages the evaluation context properly.----step    :: (Ord p, Show p)-        => Config s p w-        -> World w -> Exp s p-        -> IO (Either Result (Exp s p))--step !config !world !xx- = case xx of-        -- Reference-        XRef ref-         -> case ref of-                -- Expand macro declarations.-                RMac n-                  -> case Map.lookup n (configDeclsMac config) of-                        Nothing -> return $ Left ResultDone-                        Just x  -> return $ Right x--                -- Leave other references as-is.-                _ -> return $ Left ResultDone--        -- Plain variable, we're done.-        XVar{}-         -> return $ Left ResultDone--        -- Abstraction.-        XAbs ns1 x2-         -- Reduce the body of the abstraction if requested.-         |  configUnderLambdas config-         -> do  er2'     <- step config world x2-                case er2' of-                 Left  r2  -> return $ Left r2-                 Right x2' -> return $ Right $ XAbs ns1 x2'--         -- Otherwise treat abstractions as values.-         |  otherwise-         -> return $ Left ResultDone--        -- Application.-        XApp xF []-         -> return $ Right xF--        XApp{}-         -- Unzip the application and try to step the functional expression first.-         |  Just (xF, xsArgs)    <- takeXApps xx-         -> do  erx <- step (config { configUnderLambdas = False })-                            world xF-                case erx of-                 -- Functional expression makes progress.-                 Right xF'-                  -> return $ Right $ makeXApps xF' xsArgs--                 -- Evaluation of functional expression failed.-                 Left err@(ResultError _)-                  -> return $ Left err--                 -- Functional expression is done.-                 Left ResultDone-                  -> case xF of-                      XRef (RPrm primF)  -> stepAppPrm config world primF xsArgs-                      XAbs nsParam xBody -> stepAppAbs config world nsParam xBody xsArgs--                      -- Functional expression is inactive, but optionally-                      -- continue reducing arguments to eliminate all of-                      -- the redexes in the expression.-                      _ |  configHeadArgs config-                        -> do   erxArgs <- stepFirstVal config world xsArgs-                                case erxArgs of-                                 Right xsArgs' -> return $ Right $ makeXApps xF xsArgs'-                                 Left res      -> return $ Left res--                        |  otherwise-                        -> return $ Left ResultDone--         | otherwise-         -> return $ Left ResultDone--        -- Substitution trains.-        XSub{}-         -> case pushHead xx of-                Nothing  -> return $ Left ResultDone-                Just xx' -> return $ Right xx'--        -- Boxed expressions are already normal forms.-        XKey KBox _-         -> return $ Left ResultDone--        -- Run a boxed expression.-        XKey KRun x1-         -> do  erx <- step (config { configUnderLambdas = False-                                    , configHeadArgs     = False })-                            world x1--                case erx of-                 -- Body makes progress.-                 Right x1'-                  -> return $ Right (XKey KRun x1')--                 -- Body expression evaluation failed.-                 Left err@(ResultError _)-                  -> return $ Left err--                 -- If the body expression is a box then unwrap it,-                 -- otherwise just return the value as-is.-                 Left ResultDone-                  -> case x1 of-                         XKey KBox x11   -> return $ Right x11-                         _               -> return $ Right x1------------------------------------------------------------------------------------- | Step an application of a primitive operators to its arguments.-stepAppPrm-        :: (Ord p, Show p)-        => Config s p w-        -> World w -> p -> [Exp s p]-        -> IO (Either Result (Exp s p))--stepAppPrm !config !world !prim !xsArgs- = case Map.lookup prim (configPrims config) of-        Nothing         -> return $ Left ResultDone-        Just primEval   -> stepPrim config world primEval xsArgs------------------------------------------------------------------------------------- | Step an application of an abstraction applied to its arguments.-stepAppAbs-        :: (Ord p, Show p)-        => Config s p w-        -> World w -> [Param] -> Exp s p -> [Exp s p]-        -> IO (Either Result (Exp s p))--stepAppAbs !config !world !psParam !xBody !xsArgs- = do-        let arity         = length psParam-        let args          = length xsArgs-        let xsArgs_sat    = take arity xsArgs-        let xsArgs_remain = drop arity xsArgs-        let fsParam_sat   = map formOfParam psParam--        erxs   <- stepFirst config world xsArgs_sat fsParam_sat-        case erxs of-         -- One of the args makes progress.-         Right xsArgs_sat'-          -> do let xFun    = XAbs psParam xBody-                return $ Right-                 $ makeXApps (makeXApps xFun xsArgs_sat') xsArgs_remain--         -- Stepping one of the arguments failed.-         Left err@(ResultError _)-          ->    return $ Left err--         -- The arguments are all done.-         Left ResultDone-          -- Saturated application-          | args == arity-          -> do let nsParam = map nameOfParam psParam-                let snv     = snvOfNamesArgs nsParam xsArgs-                return $ Right-                 $ snvApply False snv xBody--          -- Under application.-          | args < arity-          -> do let psParam_sat    = take args psParam-                let nsParam_sat    = map nameOfParam psParam_sat-                let psParam_remain = drop args psParam-                let snv     = snvOfNamesArgs nsParam_sat xsArgs_sat-                return $ Right-                 $ makeXApps-                        (snvApply False snv $ XAbs psParam_remain xBody)-                        xsArgs_remain--          -- Over application.-          | otherwise-          -> do let nsParam = map nameOfParam psParam-                let snv     = snvOfNamesArgs nsParam xsArgs_sat-                return $ Right-                 $ makeXApps-                        (snvApply False snv xBody)-                        xsArgs_remain------------------------------------------------------------------------------------- | Step an application of a primitive operator to some arguments.-stepPrim-        :: (Ord p, Show p)-        => Config s p w-        -> World w -> PrimEval s p w -> [Exp s p]-        -> IO (Either Result (Exp s p))--stepPrim !config !world !pe !xsArgs- | PrimEval _prim _desc csArg eval <- pe- = let-        -- Evaluation of arguments is complete.-        evalArgs [] [] xsArgsDone-         = do   mr <- eval world (reverse xsArgsDone)-                case mr of-                 Just xResult    -> return $ Right xResult-                 Nothing         -> return $ Left ResultDone--        -- We have more args than the primitive will accept.-        evalArgs [] xsArgsRemain xsArgsDone-         = do   mr <- eval world (reverse xsArgsDone)-                case mr of-                 Just xResult    -> return $ Right $ makeXApps xResult xsArgsRemain-                 Nothing         -> return $ Left ResultDone--        -- Evaluate the next argument if needed.-        evalArgs (cArg' : csArg') (xArg' : xsArg') xsArgsDone-         -- Primitive does not demand a value fo rthis arg.-         | PExp <- cArg'-         = evalArgs csArg' xsArg' (xArg' : xsArgsDone)--         -- Primtiive demands a value for this arg.-         | otherwise-         = do   erxArg' <-  step (config { configUnderLambdas = False-                                         , configHeadArgs = False })-                                 world xArg'-                case erxArg' of-                 Left err@(ResultError _)-                  -> return $ Left err--                 Left ResultDone-                  -> evalArgs csArg' xsArg' (xArg' : xsArgsDone)--                 Right xArg''-                  -> return $ Right-                        $ makeXApps (XRef (RPrm (primEvalName pe)))-                         $ (reverse xsArgsDone) ++ (xArg'' : xsArg')--        -- We have less args than the prim will accept,-        -- so leave the application as it is.-        evalArgs _ [] _xsArgsDone-         = return $ Left ResultDone--   in   evalArgs csArg xsArgs []------------------------------------------------------------------------------------- | Step the first available expression in a list,---   reducing them all towards values.-stepFirstVal-        :: (Ord p, Show p)-        => Config s p w-        -> World w -> [Exp s p]-        -> IO (Either Result [Exp s p])--stepFirstVal !config !world !xx- = stepFirst config world xx (replicate (length xx) PVal)----- | Step the first available expression in a list.-stepFirst-        :: (Ord p, Show p)-        => Config s p w-        -> World w -> [Exp s p] -> [Form]-        -> IO (Either Result [Exp s p])--stepFirst !config !world !xx !ff- = case (xx, ff) of-        ([], _)-         -> return $ Left ResultDone--        (_,  [])-         -> return $ Left ResultDone--        (x1 : xs2, f1 : fs2)-         | PExp <- f1-         -> do  erx <- stepFirst config world xs2 fs2-                case erx of-                 Left r     -> return $ Left r-                 Right xs2' -> return $ Right $ x1 : xs2'--         | otherwise-         -> do  erx1 <- step config world x1-                case erx1 of-                 Left err@(ResultError{})-                  -> return $ Left err--                 Left ResultDone-                  -> do erxs2 <- stepFirst config world xs2 fs2-                        case erxs2 of-                         Left  r    -> return $ Left r-                         Right xs2' -> return $ Right $ x1 : xs2'--                 Right x1'-                  -> return $ Right $ x1' : xs2-
− src/SMR/Core/World.hs 
@@ -1,22 +0,0 @@--module SMR.Core.World where-import Data.IORef----- | World state for evaluation-data World w-        = World-        { -- | Generator for nominal variables.-          worldNomGen   :: !(IORef Integer)--          -- | User state-        , worldUser     :: w }----- | Initialize a new world.-worldInit :: w -> IO (World w)-worldInit w- = do   refNomGen       <- newIORef 0-        return  $ World-                { worldNomGen   = refNomGen-                , worldUser     = w }
− src/SMR/Data/Bag.hs 
@@ -1,64 +0,0 @@--module SMR.Data.Bag where-import Prelude hiding (map)-import qualified Data.List as List----- | An unordered collection of things.---   O(1) to add a single element, a list of elements, or union two bags.-data Bag a-        = BagNil-        | BagElem  a-        | BagList  [a]-        | BagUnion (Bag a) (Bag a)-        deriving Show----- | O(1). Construct an empty bag.-nil     :: Bag a-nil = BagNil----- | O(1). Construct a bag containing a single element.-singleton :: a -> Bag a-singleton x- = BagElem x----- | O(1). Construct a bag containing a list of elements.-list :: [a] -> Bag a-list xs- = BagList xs----- | O(1). Union two bags.-union :: Bag a -> Bag a -> Bag a-union xs1 xs2- = BagUnion xs1 xs2----- | O(n). Convert a bag to a list.---   The elements come out in some deterministic but arbitrary order, no promises.-toList :: Bag a -> [a]-toList bag- = go [] bag- where-        go xs1  BagNil          = xs1-        go xs1 (BagElem x)      = x : xs1-        go xs1 (BagList xs2)    = go_list xs1 xs2-        go xs1 (BagUnion b1 b2) = go (go xs1 b1) b2--        go_list _   []          = []-        go_list xs1 (x : xs2)   = go_list (x : xs1) xs2----- | Apply a function to all the elements in a bag.-map :: (a -> b) -> Bag a -> Bag b-map f bag- = case bag of-        BagNil          -> BagNil-        BagElem  x      -> BagElem  (f x)-        BagList  xs     -> BagList  (List.map f xs)-        BagUnion b1 b2  -> BagUnion (map f b1) (map f b2)--
− src/SMR/Data/Located.hs 
@@ -1,39 +0,0 @@--module SMR.Data.Located where----- | Location in a source file.-data Location-        = L  Int Int-        deriving Show----- | A thing located at the given range in a source file.-data Located a-        = LL Location Location a-        deriving Show----- | Take the start point of a located thing.-startOfLocated :: Located a -> Location-startOfLocated (LL start _ _) = start----- | Take the end point of a located thing.-endOfLocated :: Located a -> Location-endOfLocated (LL _ end _) = end----- | Take the value of a located thing.-valueOfLocated :: Located a -> a-valueOfLocated (LL _ _ x) = x---- | Increment the character position of a located thing.-incCharOfLocation :: Int -> Location -> Location-incCharOfLocation n (L l c) = L l (c + n)----- | Increment the line position of a located thing.-incLineOfLocation :: Int -> Location -> Location-incLineOfLocation n (L l _) = L (l + n) 1-
− src/SMR/Prim/Name.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module SMR.Prim.Name where-import SMR.Prim.Op.Base-import Data.Text                (Text)-import Data.Set                 (Set)-import qualified Data.Set       as Set-import qualified Data.Char      as Char-import qualified Data.Text      as Text----- | Pretty print a primitive operator.-pprPrim :: Prim -> Text-pprPrim pp- = case pp of-        PrimOp op          -> op--        PrimLitBool True   -> "true"-        PrimLitBool False  -> "false"--        PrimLitNat n       -> Text.pack $ "nat'" ++ show n--        PrimTagUnit        -> "unit"-        PrimTagList        -> "list"----- | Parse a primitive name, without the leading '#'.-readPrim :: Set Text -> Text -> Maybe Prim-readPrim ps tx- -- Literal Booleans.- | tx == "true"         = Just $ PrimLitBool True- | tx == "false"        = Just $ PrimLitBool False-- -- Literal Nats.- | Text.isPrefixOf "nat'" tx- , tx'  <- Text.unpack $ Text.drop 4 tx- , all Char.isDigit tx'- , not $ null tx'- = Just $ PrimLitNat (read tx')-- -- Other primtiives.- | Set.member tx ps- = Just $ PrimOp tx-- | tx == "unit" = Just PrimTagUnit- | tx == "list" = Just PrimTagList-- -- Unrecognised.- | otherwise- = Nothing
− src/SMR/Prim/Op.hs 
@@ -1,27 +0,0 @@-module SMR.Prim.Op where-import SMR.Prim.Op.Base-import SMR.Prim.Op.Bool-import SMR.Prim.Op.Nat-import SMR.Prim.Op.Sym-import SMR.Prim.Op.Nom-import SMR.Prim.Op.List-import SMR.Prim.Op.Match-import Data.Text                (Text)-import Data.Set                 (Set)-import qualified Data.Set       as Set---primEvals :: [PrimEval Text Prim w]-primEvals- = concat-        [ primOpsBool-        , primOpsNat-        , primOpsList-        , primOpsSym-        , primOpsNom-        , primOpsMatch ]---primOpTextNames :: Set Text-primOpTextNames- = Set.fromList [ n | PrimOp n <- map primEvalName $ primEvals ]
− src/SMR/Prim/Op/Base.hs 
@@ -1,113 +0,0 @@--module SMR.Prim.Op.Base-        ( Prim          (..)-        , PrimEval      (..)--          -- * Exp-        , takeArgExp--          -- * Bool-        , makeXBool, takeXBool, takeArgBool--          -- * Nat-        , makeXNat, takeXNat,  takeArgNat--          -- * List-        , makeXList)-where-import SMR.Core.Exp-import SMR.Core.World-import Data.Text        (Text)------------------------------------------------------------------------------------- | Primitive values and operators.-data Prim-        = PrimOp        Text-        | PrimLitBool   Bool-        | PrimLitNat    Integer-        | PrimTagUnit-        | PrimTagList-        deriving (Eq, Ord, Show)----- Exp ------------------------------------------------------- | Take the first expression argument from a list of primitives.-takeArgExp-        :: [Exp s Prim]-        -> Maybe (Exp s Prim, [Exp s Prim])-takeArgExp xx- = case xx of-        x1 : xs -> Just (x1, xs)-        _       -> Nothing----- Bool ------------------------------------------------------ | Take a literal Bool from an expression.-takeXBool :: Exp s Prim -> Maybe Bool-takeXBool xx- = case xx of-        XRef (RPrm (PrimLitBool b))     -> Just b-        _                               -> Nothing----- | Make a literal Bool expression.-makeXBool :: Bool -> Exp s Prim-makeXBool b- = XRef (RPrm (PrimLitBool b))----- | Split a literal Bool from an argument list.-takeArgBool :: [Exp s Prim] -> Maybe (Bool, [Exp s Prim])-takeArgBool xx- = case xx of-        XRef (RPrm (PrimLitBool b)) : xs-          -> Just (b, xs)-        _ -> Nothing----- Nat ------------------------------------------------------- | Take a literal Nat from an expression.-takeXNat :: Exp s Prim -> Maybe Integer-takeXNat xx- = case xx of-        XRef (RPrm (PrimLitNat n))      -> Just n-        _                               -> Nothing---- | Make a literal Nat expression.-makeXNat :: Integer -> Exp s Prim-makeXNat n- = XRef (RPrm (PrimLitNat n))----- | Split a literal Nat from an argument list.-takeArgNat :: [Exp s Prim] -> Maybe (Integer, [Exp s Prim])-takeArgNat xx- = case xx of-        XRef (RPrm (PrimLitNat n)) : xs-          -> Just (n, xs)-        _ -> Nothing----- List ------------------------------------------------------ | Make a list of expressions.-makeXList :: [Exp s Prim] -> Exp s Prim-makeXList xs- = XApp (XRef (RPrm PrimTagList)) xs------------------------------------------------------------------------------------- | Primitive evaluator.-data PrimEval s p w-        = PrimEval-        { primEvalName  :: p            -- ^ Op name.-        , primEvalDesc  :: Text         -- ^ Op description.-        , primEvalForm  :: [Form]       -- ^ Argument passing methods.--          -- | Evaluation function.-        , primEvalFun-                :: World w-                -> [Exp s p]-                -> IO (Maybe (Exp s p))-        }-
− src/SMR/Prim/Op/Bool.hs 
@@ -1,66 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module SMR.Prim.Op.Bool where-import SMR.Core.Exp-import SMR.Prim.Op.Base-import Data.Text        (Text)----- | Primitive evaluators for boolean operators.-primOpsBool :: [PrimEval s Prim w]-primOpsBool- = [ primOpBool1 "not" "boolean negation" (\b -> not b)-   , primOpBool2 "and" "boolean and"      (&&)-   , primOpBool2 "or"  "boolean or"       (||)-   , primOpIf ]----- | Construct an evaluator for 1-arity bool operator.-primOpBool1-        :: Name -> Text-        -> (Bool -> Bool)-        -> PrimEval s Prim w--primOpBool1 name desc fn- = PrimEval (PrimOp name) desc [PVal] fn'- where  fn' _world as0-         | Just (b1, []) <- takeArgBool as0-         = return $ Just $ makeXBool (fn b1)-        fn' _world _-         = return $ Nothing----- | Construct an evaluator for 2-arity bool operator.-primOpBool2-        :: Name -> Text-        -> (Bool -> Bool -> Bool)-        -> PrimEval s Prim w--primOpBool2 name desc fn- = PrimEval (PrimOp name) desc [PVal, PVal] fn'- where-        fn' _world as0-         | Just (b1, as1) <- takeArgBool as0-         , Just (b2, [])  <- takeArgBool as1-         = return $ Just $ makeXBool (fn b1 b2)-        fn' _world _-         = return $ Nothing----- | Primitive evaluator for the #if operator.---   Only the scrutinee is demanded, while the branches are not.-primOpIf :: PrimEval s Prim w-primOpIf- = PrimEval-        (PrimOp "if")-        "boolean if-then-else operator"-        [PVal, PExp, PExp] fn'- where-        fn' _world as0-         | Just (b1, as1) <- takeArgBool as0-         , Just (x1, as2) <- takeArgExp  as1-         , Just (x2, [])  <- takeArgExp  as2-         = return $ Just $ if b1 then x1 else x2--        fn' _world _-         = return $ Nothing-
− src/SMR/Prim/Op/List.hs 
@@ -1,106 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module SMR.Prim.Op.List where-import SMR.Core.Exp-import SMR.Prim.Op.Base----- | Primitive evaluators for list operators.-primOpsList :: [PrimEval s Prim w]-primOpsList- = [ primOpListCons,    primOpListUncons-   , primOpListSnoc,    primOpListUnsnoc-   , primOpListAppend ]----- | Cons an element to a the front of a list.-primOpListCons :: PrimEval s Prim w-primOpListCons- = PrimEval-        (PrimOp "list-cons")-        "add an element to the front of a list"-        [PExp, PVal] fn'- where-        fn' _world as0-         | Just (x1, as1) <- takeArgExp as0-         , Just (XApp tag@(XRef (RPrm PrimTagList)) xs, [])-                          <- takeArgExp as1-         = return $ Just $ XApp tag (x1 : xs)--        fn' _world _-         = return $ Nothing----- | Split an element from the front of a list.-primOpListUncons :: PrimEval s Prim w-primOpListUncons- = PrimEval-        (PrimOp "list-uncons")-        "split an element from the front of a list"-        [PVal, PExp] fn'- where-        fn' _world as0-         | Just (XApp tag@(XRef (RPrm PrimTagList)) xx, as1)-                          <- takeArgExp as0-         , Just (x2, [])  <- takeArgExp as1-         = case xx of-                x1 : xs -> return $ Just $ XApp x2 [x1, XApp tag xs]-                []      -> return $ Nothing-        fn' _world _-         = return $ Nothing----- | Snoc an element to a the end of a list.-primOpListSnoc :: PrimEval s Prim w-primOpListSnoc- = PrimEval-        (PrimOp "list-snoc")-        "add an element to the end of a list"-        [PVal, PExp] fn'- where-        fn' _world as0-         | Just (XApp tag@(XRef (RPrm PrimTagList)) xs, as1)-                          <- takeArgExp as0-         , Just (x1, [])  <- takeArgExp as1-         = return $ Just $ XApp tag (xs ++ [x1])-        fn' _world _-         = return $ Nothing----- | Unsnoc an element from the end of a list.-primOpListUnsnoc :: PrimEval s Prim w-primOpListUnsnoc- = PrimEval-        (PrimOp "list-unsnoc")-        "split an element from the end of a list"-        [PVal, PExp] fn'- where-        fn' _world as0-         | Just (XApp tag@(XRef (RPrm PrimTagList)) xx, as1)-                          <- takeArgExp as0-         , Just (x2, [])  <- takeArgExp as1-         = case reverse xx of-                x1 : xs -> return $ Just $ XApp x2 [XApp tag (reverse xs), x1]-                []      -> return $ Nothing--        fn' _world _-         = return $ Nothing----- | Append two lists.-primOpListAppend :: PrimEval s Prim w-primOpListAppend- = PrimEval-        (PrimOp "list-append")-        "append two lists"-        [PVal, PVal] fn'- where-        fn' _world as0-         | Just (XApp (XRef (RPrm PrimTagList)) xs1, as1)-                          <- takeArgExp as0-         , Just (XApp tag@(XRef (RPrm PrimTagList)) xs2, [])-                          <- takeArgExp as1-         = return $ Just (XApp tag (xs1 ++ xs2))--        fn' _world _-         = return $ Nothing-
− src/SMR/Prim/Op/Match.hs 
@@ -1,163 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ParallelListComp  #-}-module SMR.Prim.Op.Match where-import SMR.Core.Exp-import SMR.Core.World-import SMR.Prim.Op.Base-import Data.IORef----- | Primitive matching operators.-primOpsMatch :: [PrimEval s Prim w]-primOpsMatch- = [ primOpMatchSym-   , primOpMatchApp-   , primOpMatchAbs-   , primOpMatchAbs1 ]------ | Match against a given symbol.-primOpMatchSym :: PrimEval s Prim w-primOpMatchSym- = PrimEval-        (PrimOp "match-sym")-        "match a symbol"-        [PVal, PExp, PExp] fn'- where-        fn' _world as0-         | Just (x1, as1) <- takeArgExp as0-         , Just (x2, as2) <- takeArgExp as1-         , Just (x3, [])  <- takeArgExp as2-         = case x1 of-                XRef (RSym _s1)-                  -> return $ Just $ XApp x3 [x1]-                _ -> return $ Just $ x2--        fn' _world _-         = return $ Nothing----- | Match an application.---   TODO(BL: pack the args into a list)-primOpMatchApp :: PrimEval s Prim w-primOpMatchApp- = PrimEval-        (PrimOp "match-app")-        "match an application"-        [PVal, PExp, PExp] fn'- where-        fn' _world as0-         | Just (x1, as1) <- takeArgExp as0-         , Just (x2, as2) <- takeArgExp as1-         , Just (x3, [])  <- takeArgExp as2-         = case x1 of-                XRef{}          -> return $ Nothing-                XKey{}          -> return $ Nothing-                XApp x11 xs12   -> return $ Just $ XApp x3 (x11 : xs12)-                XVar{}          -> return $ Nothing-                XAbs{}          -> return $ Just x2-                XSub{}          -> return $ Nothing--        fn' _world _-         = return $ Nothing------ | Match all parameters of an abstraction.-primOpMatchAbs :: PrimEval s Prim w-primOpMatchAbs- = PrimEval-        (PrimOp "match-abs")-        "match all parameters of an abstraction"-        [PVal, PExp, PExp] fn'- where-        fn' world as0-         | Just (x1, as1) <- takeArgExp as0-         , Just (x2, as2) <- takeArgExp as1-         , Just (x3, [])  <- takeArgExp as2-         = case x1 of-            XAbs ps11 x12 -> fnAbs world x3 ps11 x12-            _             -> return $ Just $ x2--        fn' _world _-         = return Nothing--        newNom world _-         = do   ix <- atomicModifyIORef (worldNomGen world)-                   $  \ix -> (ix + 1, ix)--                return ix--        fnAbs world x2 ps11 x12-         = do   -- Create new variables for each of the parameters.-                ixs     <- mapM (newNom world) ps11--                let boolOfForm PVal = True-                    boolOfForm PExp = False--                let xIxs-                        = makeXList-                                [ makeXList-                                        [ XRef (RNom ix)-                                        , XRef (RPrm (PrimLitBool (boolOfForm $ formOfParam p))) ]-                                | ix <- ixs | p  <- ps11 ]--                let xBody-                        = XSub  [CSim  (SSnv [BindVar (nameOfParam p) 0 (XRef (RNom ix))-                                              | p  <- ps11 | ix <- ixs ])]-                                 x12--                return  $ Just-                        $ XApp x2 (xIxs : [xBody])----- | Match the first parameter of an abstraction.-primOpMatchAbs1 :: PrimEval s Prim w-primOpMatchAbs1- = PrimEval-        (PrimOp "match-abs1")-        "match the first parameter of an abstraction"-        [PVal, PExp, PExp] fn'- where-        fn' world as0-         | Just (x1, as1) <- takeArgExp as0-         , Just (x2, as2) <- takeArgExp as1-         , Just (x3, [])  <- takeArgExp as2-         = case x1 of-            XRef{}        -> return $ Nothing-            XKey{}        -> return $ Nothing-            XApp{}        -> return $ Just x2-            XVar{}        -> return $ Nothing-            XAbs ps11 x12 -> fnAbs world x3 ps11 x12-            XSub{}        -> return $ Nothing--        fn' _world _-         = return Nothing--        newNom world _-         = do   ix <- atomicModifyIORef (worldNomGen world)-                   $  \ix -> (ix + 1, ix)--                return ix--        fnAbs _world _x2 [] _x12-         = return Nothing--        fnAbs world x2 (p1 : ps11) x12-         = do   ix      <- newNom world p1--                let boolOfForm PVal = True-                    boolOfForm PExp = False--                let xIx = makeXList-                        [ XRef (RNom ix)-                        , XRef (RPrm (PrimLitBool (boolOfForm $ formOfParam p1))) ]--                let xBody-                        = XSub [ CSim (SSnv [BindVar (nameOfParam p1) 0 (XRef (RNom ix))])]-                        $ makeXAbs ps11 x12--                return  $ Just-                        $ XApp x2 (xIx : [xBody])-
− src/SMR/Prim/Op/Nat.hs 
@@ -1,53 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module SMR.Prim.Op.Nat where-import SMR.Core.Exp-import SMR.Prim.Op.Base---type Nat = Integer---- | Primitive evaluators for nat operators.-primOpsNat :: [PrimEval s Prim w]-primOpsNat- = [ primOpNat2Nat  "nat-add" "natural addition"            (+)-   , primOpNat2Nat  "nat-sub" "natural subtration"-        (\a b -> let x = a - b-                 in if x < 0 then 0 else x)--   , primOpNat2Nat  "nat-mul" "natural multiplication"      (*)-   , primOpNat2Nat  "nat-div" "natural division"            div-   , primOpNat2Nat  "nat-rem" "natural remainder"           rem-   , primOpNat2Bool "nat-eq"  "natural equality"            (==)-   , primOpNat2Bool "nat-neq" "natural negated equality"    (/=)-   , primOpNat2Bool "nat-lt"  "natural less than"           (<)-   , primOpNat2Bool "nat-le"  "natural less than equal"     (<=)-   , primOpNat2Bool "nat-gt"  "natural greater than"        (>)-   , primOpNat2Bool "nat-ge"  "natural greather than equal" (>=) ]----- | Construct an evaluator for a 2-arity nat operator returning nat.-primOpNat2Nat-        :: Text -> Text -> (Nat -> Nat -> Nat)-        -> PrimEval s Prim w-primOpNat2Nat name desc fn- =  PrimEval (PrimOp name) desc [PVal, PVal] fn'- where  fn' _world as0-         | Just (n1, as1) <- takeArgNat as0-         , Just (n2, [])  <- takeArgNat as1-         = return $ Just $ makeXNat (fn n1 n2)-        fn' _world _-         = return $ Nothing----- | Construct an evaluator for a 2-arity nat operator returning bool.-primOpNat2Bool-        :: Text -> Text -> (Nat -> Nat -> Bool)-        -> PrimEval s Prim w-primOpNat2Bool name desc fn- =  PrimEval (PrimOp name) desc [PVal, PVal] fn'- where  fn' _world as0-         | Just (n1, as1) <- takeArgNat as0-         , Just (n2, [])  <- takeArgNat as1-         = return $ Just $ makeXBool (fn n1 n2)-        fn' _world _-         = return $ Nothing
− src/SMR/Prim/Op/Nom.hs 
@@ -1,68 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module SMR.Prim.Op.Nom where-import SMR.Prim.Op.Base-import SMR.Core.Exp.Base-import SMR.Core.World-import Data.IORef----- | Primitive evalutor for nominal variable operators.-primOpsNom :: [PrimEval s Prim w]-primOpsNom- = [ primOpNomEq-   , primOpNomFresh-   , primOpNomClose ]----- | Check for equality of two nominal variables.-primOpNomEq :: PrimEval s Prim w-primOpNomEq- = PrimEval-        (PrimOp "nom-eq")-        ("check equality of two nominal variables")-        [PVal, PVal] fn'- where-        fn' _world as0-         | Just (XRef (RNom n1), as1) <- takeArgExp as0-         , Just (XRef (RNom n2), [])  <- takeArgExp as1-         = return $ Just-                  $ if n1 == n2 then XRef $ RPrm $ PrimLitBool True-                                else XRef $ RPrm $ PrimLitBool False-        fn' _world _-         = return $ Nothing----- | Allocate a fresh nominal variable.-primOpNomFresh :: PrimEval s Prim w-primOpNomFresh- = PrimEval-        (PrimOp "nom-fresh")-        "allocate a fresh nominal variable"-        [PVal] fn'- where-        fn' world as0-         | Just (XRef (RPrm PrimTagUnit), []) <- takeArgExp as0-         = do   ix  <- readIORef (worldNomGen world)-                writeIORef (worldNomGen world) (ix + 1)-                return $ Just $ XRef (RNom ix)--        fn' _world _-         = do   return $ Nothing----- | Create a closing substitution for a nominal variable.-primOpNomClose :: PrimEval s Prim w-primOpNomClose- = PrimEval-        (PrimOp "nom-close")-        ("creating a closing substitution for a nominal variable")-        [PVal, PExp, PExp] fn'- where-        fn' _world as0-         | Just (XRef (RNom n1), as1) <- takeArgExp as0-         , Just (x1, as2)  <- takeArgExp as1-         , Just (x2, [])   <- takeArgExp as2-         = return $ Just $ XSub [CSim (SSnv [BindNom n1 x1])] x2--        fn' _world _-         = return $ Nothing
− src/SMR/Prim/Op/Sym.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module SMR.Prim.Op.Sym where-import SMR.Prim.Op.Base-import SMR.Core.Exp.Base----- | Primitive evaluator for symbol operators.-primOpsSym :: Eq s => [PrimEval s Prim w]-primOpsSym- = [ primOpSymEq ]----- | Check equality of two symbols.-primOpSymEq :: Eq s => PrimEval s Prim w-primOpSymEq- = PrimEval-        (PrimOp "sym-eq")-        ("check equality of two symbols")-        [PVal, PVal] fn'- where-        fn' _world as0-         | Just (XRef (RSym n1), as1) <- takeArgExp as0-         , Just (XRef (RSym n2), [])  <- takeArgExp as1-         = return $ Just-                  $ if n1 == n2 then XRef $ RPrm $ PrimLitBool True-                                else XRef $ RPrm $ PrimLitBool False-        fn' _world _-         = return $ Nothing
− src/SMR/Source/Expected.hs 
@@ -1,106 +0,0 @@--module SMR.Source.Expected where-import SMR.Source.Parsec-import SMR.Source.Token-import SMR.Data.Located-import SMR.Data.Bag                     (Bag)-import Data.Text                        (Text)-import qualified SMR.Data.Bag           as Bag-import qualified Data.Text              as Text------------------------------------------------------------------------------------ | What we were expecting at the point there was a parse error.-data Expected t s p-        -- | Expecting end of input.-        = ExBaseEnd--        -- | Expecting a name in the given namespace.-        | ExBaseNameOf  Space--        -- | Expecting a name in any namespace.-        | ExBaseNameAny--        -- | Expecting a natural number.-        | ExBaseNat--        -- | Expecting a punctuation character.-        | ExBasePunc    Char--        -- | Expecting something described by the given message.-        | ExBaseMsg     String--        -- | Expecting something while parsing a declaration.-        | ExContextDecl-                Text-                (Bag (Blocker t (Expected t s p)))--        -- | Expecting something while parsing a binding.-        | ExContextBind-                Text-                (Bag (Blocker t (Expected t s p)))-        deriving Show----- | Pretty print an expected thing.-pprExpected-        :: (Show s, Show p)-        => Expected (Located Token) s p -> String-pprExpected bb- = case bb of-        ExBaseEnd       -> "expecting end of input"-        ExBaseNameOf s  -> "expecting name " ++ show s-        ExBaseNat       -> "expecting natural number"-        ExBasePunc c    -> "expecting " ++ show c-        ExBaseMsg t     -> "expecting " ++ show t-        ExBaseNameAny   -> "expecting name"--        ExContextDecl n es-         -> "in declaration @" ++ Text.unpack n ++ "\n"-         ++ (unlines $ map pprBlocker $ Bag.toList es)--        ExContextBind n esBag-         | e : _        <- Bag.toList esBag-         -> "in binding " ++ Text.unpack n ++ "\n"-         ++ pprBlocker e--         | otherwise-         -> "in binding " ++ Text.unpack n----- | Pretty print a blocker.-pprBlocker-        :: (Show s, Show p)-        => Blocker (Located Token) (Expected (Located Token) s p)-        -> String--pprBlocker (Blocker [] e)- = pprExpected e--pprBlocker (Blocker (t : _) e)- =  pprLocation (startOfLocated t)- ++ " " ++ pprExpected e---pprLocation :: Location -> String-pprLocation (L l c)- = show l ++ ":" ++ show c------------------------------------------------------------------------------------- | Parser error.-data ParseError t e-        = ParseError [Blocker t e]-        deriving Show----- | Pretty print a parser error.-pprParseError-        :: (Show s, Show p)-        => ParseError (Located Token) (Expected (Located Token) s p) -> String--pprParseError (ParseError [])- = "at end of input"--pprParseError (ParseError (b : _bs))- = pprBlocker b-
− src/SMR/Source/Lexer.hs 
@@ -1,179 +0,0 @@--module SMR.Source.Lexer-        ( lexTokens-        , Located (..)-        , Location(..))-where-import SMR.Source.Token-import SMR.Data.Located-import Data.Text                (Text)-import qualified Data.Text      as Text-import qualified Data.Char      as Char----- Lexer ------------------------------------------------------------------------- | Lex a sequence of tokens.-lexTokens :: Location -> [Char] -> ([Located Token], Location, [Char])-lexTokens lStart0 cs0- = case skipSpace lStart0 cs0 of-    (lStart, [])-     -> ( LL lStart lStart KEnd : []-        , lStart, [])--    (lStart, cs)-     -> case lexToken lStart cs of-         Nothing-          -> ([], lStart, cs)--         Just (k, cs')-          |  (ks, lStart', cs'') <- lexTokens (endOfLocated k) cs'-          -> (k : ks, lStart', cs'')----- | Lex a single token.-lexToken :: Location -> [Char] -> Maybe (Located Token, [Char])-lexToken lStart xx- = case xx of-    []-     -> Nothing--    c : cs-        -- Punctuation.-        |  isCharPunc c-        -> let  lEnd = incCharOfLocation 1 lStart-                tok  = KPunc c-           in   Just (LL lStart lEnd tok, cs)--        -- Variable name.-        |  Just (space, xx')         <- takeSpace c cs-        ,  Just (name, lEnd, csRest) <- lexName   (incCharOfLocation 1 lStart) xx'-        -> let  tok      = KName space name-           in   Just (LL lStart lEnd tok, csRest)--        --  Natural number.-        |  Char.isDigit c-        ,  Just (nat, lEnd, csRest)  <- lexNat lStart (c : cs)-        -> let  tok      = KNat nat-           in   Just (LL lStart lEnd tok, csRest)--        |  otherwise-        -> Nothing----- | Lex a variable name.-lexName :: Location -> [Char] -> Maybe (Text, Location, [Char])-lexName lStart xx- = go lStart [] xx- where-        go lStart' acc []-         | not $ null acc-         = let  name    = Text.pack $ reverse acc-           in   Just (name, lStart', [])--         | otherwise-         = Nothing--        go lStart' acc (c : cs)-         | isNameBodyChar c-         =      go (incCharOfLocation 1 lStart') (c : acc) cs--         | otherwise-         = let  name    = Text.pack $ reverse acc-           in   Just (name, lStart', c : cs)----- | Lex a natural number.-lexNat  :: Location -> [Char] -> Maybe (Integer, Location, [Char])-lexNat lStart xx- = go lStart [] xx- where-        go lStart' acc []-         | not $ null acc-         , all Char.isDigit acc-         , nat <- read $ reverse acc-         = Just (nat, lStart', [])--        go lStart' acc (c : cs)-         | Char.isDigit c-         = go (incCharOfLocation 1 lStart') (c : acc) cs--         | all Char.isDigit acc-         , not $ null acc-         , nat <- read $ reverse acc-         = Just (nat, lStart', c : cs)--        go _ _ _-         = Nothing----- Whitespace ------------------------------------------------------------------skipSpace :: Location -> [Char] -> (Location, [Char])-skipSpace lStart xx- = case xx of-    []  -> (lStart, xx)--    c : cs-        -- Skip whitespace.-        | c == ' '  -> skipSpace (incCharOfLocation 1 lStart) cs-        | c == '\n' -> skipSpace (incLineOfLocation 1 lStart) cs-        | c == '\t' -> skipSpace (incCharOfLocation 8 lStart) cs--        -- Skip comments-        |  c  == '-'-        ,  c2 : cs2 <- cs-        ,  c2 == '-'-        -> skipSpace lStart $ dropWhile (\x -> x /= '\n') cs2--        | otherwise -> (lStart, xx)----- | Take the namespace qualifier from the front of a name.-takeSpace :: Char -> [Char] -> Maybe (Space, [Char])-takeSpace c cs- | Char.isLower c = Just (SVar, c : cs)- | c  == '@'    = Just (SMac, cs)- | c  == '%'    = Just (SSym, cs)- | c  == '+'    = Just (SSet, cs)- | c  == '#'- , c' : cs' <- cs- , c' == '#'- = Just (SKey, cs')-- | c == '#'     = Just (SPrm, cs)- | otherwise    = Nothing----- Character Classes ------------------------------------------------------------- | Check if this character can appear in the body of a name.-isNameBodyChar :: Char -> Bool-isNameBodyChar c- =  Char.isLower c- || Char.isUpper c- || Char.isDigit c- || (c == '-' || c == '\'' || c == '_')----- | Check if this is a punctuation character.-isCharPunc :: Char -> Bool-isCharPunc c- | c == '('     = True- | c == ')'     = True- | c == '{'     = True- | c == '}'     = True- | c == '['     = True- | c == ']'     = True- | c == '<'     = True- | c == '>'     = True- | c == '^'     = True- | c == ','     = True- | c == ':'     = True- | c == '\\'    = True- | c == '.'     = True- | c == ';'     = True- | c == '='     = True- | c == '$'     = True- | c == '!'     = True- | c == '~'     = True- | c == '?'     = True- | otherwise    = False-
− src/SMR/Source/Parsec.hs 
@@ -1,368 +0,0 @@---- | Parser combinator framework.-module SMR.Source.Parsec where-import qualified SMR.Data.Bag   as Bag-import SMR.Data.Bag             (Bag)------------------------------------------------------------------------------------ | Parser is a function that takes a list of tokens,---   and returns a list of remaining tokens along with---    (on error)   a list of descriptions of expected input,---    (on success) a parsed value.----data Parser t e a-        = Parser ([t] -> ParseResult t e a)----- | Result of a parser,---   parameterised by---      (t) the type of tokens,---      (e) the type for decriptions of what we're expecting to parse.---      (a) type of value to parse.----data ParseResult t e a-        -- | Parser failed after consuming no input.-        --   The parser looked at one or more tokens at the front of the-        --   input but based on these the input does not look like whatever-        --   syntax the parser was supposed to parse.-        = ParseSkip-            (Bag (Blocker t e)) --  Where we got blocked trying other parses.--        -- | Parser yielding a value after consuming no input.-        --   The parser returned a value without looking at any tokens,-        --   this is a pure value returning action.-        | ParseReturn-            (Bag (Blocker t e)) --   Where we got blocked trying other parses.-            a                   --   Produced value.--        -- | Parse failed after partially consuming input.-        --   The parser thought that the input sequence looked like what it-        --   was supposed to parse, but complete parsing failed once it-        --   had committed.-        | ParseFailure-           (Bag (Blocker t e))  --   Where we got blocked trying other parses.--        -- | Parse succeeded yielding a value after consuming input.-        --   We have a complete value, and have consumed some input tokens.-        | ParseSuccess-            a                   --   Produced value.-           [t]                  --   Remaining input tokens.-        deriving Show----- | Describes why the parser could not make further progress.-data Blocker t e-        = Blocker-        { blockerTokens   :: [t] -- ^ Remaining input tokens where we failed.-        , blockerExpected :: e   -- ^ Description of what we were expecting.-        }-        deriving Show------------------------------------------------------------------------------------- | Apply a parser to a list of input tokens.-parse :: Parser t e a -> [t] -> ParseResult t e a-parse (Parser p) ts = p ts----- Functor ---------------------------------------------------------------------instance Functor (Parser t e) where- fmap f parserA-  = Parser $ \ts0-  -> case parse parserA ts0 of-        ParseSkip    bs1        -> ParseSkip    bs1-        ParseReturn  bs1 x      -> ParseReturn  bs1 (f x)-        ParseFailure bs1        -> ParseFailure bs1-        ParseSuccess a ts1      -> ParseSuccess (f a) ts1----- Applicative -----------------------------------------------------------------instance Applicative (Parser t e) where- pure x-  = Parser $ \_-  -> ParseReturn Bag.nil x-- (<*>) parserF parserA-  = Parser $ \ts0-  -> case parse parserF ts0 of-        ParseSkip es1-         -> ParseSkip es1--        ParseFailure bs1-         -> ParseFailure bs1--        ParseReturn es1 f-         -> case parse parserA ts0 of-             ParseSkip    es2   -> ParseSkip    (Bag.union es1 es2)-             ParseReturn  es2 x -> ParseReturn  (Bag.union es1 es2) (f x)-             ParseFailure bs2   -> ParseFailure (Bag.union es1 bs2)-             ParseSuccess x ts2 -> ParseSuccess (f x) ts2--        ParseSuccess f ts1-         -> case parse parserA ts1 of-             ParseSkip    bs2   -> ParseFailure bs2-             ParseReturn  _ x   -> ParseSuccess (f x) ts1-             ParseFailure bs2   -> ParseFailure bs2-             ParseSuccess x ts2 -> ParseSuccess (f x) ts2----- Monad -----------------------------------------------------------------------instance Monad (Parser t e) where- return x-  = Parser $ \_-  -> ParseReturn Bag.nil x-- (>>=) parserA mkParserB-  = Parser $ \ts0-  -> case parse parserA ts0 of-        ParseSkip bs1-         -> ParseSkip bs1--        ParseFailure bs1-         -> ParseFailure bs1--        -- First parser produced a value but did not consume input.-        ParseReturn _ xa-         -> parse (mkParserB xa) ts0--        -- First parser produced a value and consumed input.-        ParseSuccess xa ts1-         -> case parse (mkParserB xa) ts1 of-             -- The second parser skipped, but as we've already consumed-             -- input tokens we treat this as a failure.-             ParseSkip    bs2    -> ParseFailure bs2--             -- The second parser returned a value, and though it didn't-             -- consume input itself, the whole computation has,-             -- so still treat this as a success.-             ParseReturn  _ xb   -> ParseSuccess xb ts1--             -- The second parser failed.-             ParseFailure bs2    -> ParseFailure bs2--             -- The second parser suceeded, to take the new value.-             ParseSuccess xb ts2 -> ParseSuccess xb ts2----- Prim -------------------------------------------------------------------------- Primitive parsers.---- | Always fail, producing no possible parses and no helpful error message.-fail :: Parser t e a-fail- =  Parser $ \_- -> ParseFailure Bag.nil----- | Always fail, yielding the given message describing what was expected.-expected :: e -> Parser t e a-expected xe- =  Parser $ \ts- -> ParseFailure (Bag.singleton (Blocker ts xe))----- | Commit to the given parser, so if it skips or returns without---   consuming any input then treat that as failure.-commit :: Parser t e a -> Parser t e a-commit parserA- =  Parser $ \ts0- -> case parse parserA ts0 of-        ParseSkip    bs1        -> ParseFailure bs1-        ParseReturn  bs1 _      -> ParseFailure bs1-        ParseFailure bs1        -> ParseFailure bs1-        ParseSuccess xb xs2     -> ParseSuccess xb xs2----- | Parse in an expectation context.-enter :: (Bag (Blocker t e) -> e) -> Parser t e a -> Parser t e a-enter mk parserA- = Parser $ \ts0- -> case parse parserA ts0 of-        ParseSkip    bs1-         -> ParseSkip    (Bag.singleton (Blocker ts0 (mk bs1)))--        ParseReturn  bs1 x-         -> ParseReturn  (Bag.singleton (Blocker ts0 (mk bs1))) x--        ParseFailure bs1-         -> ParseFailure (Bag.singleton (Blocker ts0 (mk bs1)))--        ParseSuccess xb ts2-         -> ParseSuccess xb ts2----- | If the given parser suceeds then enter an expectation context---   for the next one.-enterOn :: Parser t e a-        -> (a -> Bag (Blocker t e) -> e)-        -> (a -> Parser t e b)-        -> Parser t e b--enterOn parserA mk mkParserB- = Parser $ \ts0- -> case parse parserA ts0 of-        ParseSkip bs0-         -> ParseSkip bs0--        ParseFailure bs1-         -> ParseFailure bs1--        ParseReturn _ xa-         -> case parse (mkParserB xa) ts0 of-                ParseSkip bs2-                 -> ParseSkip    (Bag.singleton (Blocker ts0 (mk xa bs2)))--                ParseReturn bs2 xb-                 -> ParseReturn  (Bag.singleton (Blocker ts0 (mk xa bs2))) xb--                ParseFailure bs2-                 -> ParseFailure (Bag.singleton (Blocker ts0 (mk xa bs2)))--                ParseSuccess xb ts2-                 -> ParseSuccess xb ts2---        ParseSuccess xa ts1-         -> case parse (mkParserB xa) ts1 of-                ParseSkip bs2-                 -> ParseSkip    (Bag.singleton (Blocker ts0 (mk xa bs2)))--                ParseReturn bs2 xb-                 -> ParseReturn  (Bag.singleton (Blocker ts0 (mk xa bs2))) xb--                ParseFailure bs2-                 -> ParseFailure (Bag.singleton (Blocker ts0 (mk xa bs2)))--                ParseSuccess xb ts2-                 -> ParseSuccess xb ts2----- | Peek at the first input token, without consuming at it.-peek :: Parser t e t-peek- = Parser $ \ts- -> case ts of-        []              -> ParseFailure Bag.nil-        t : _           -> ParseReturn  Bag.nil t----- | Consume the first input token, failing if there aren't any.-item :: e -> Parser t e t-item xe- = Parser $ \ts- -> case ts of-        []              -> ParseSkip   (Bag.singleton (Blocker ts xe))-        t : ts'         -> ParseSuccess t ts'----- | Consume the first input token if it matches the given predicate,---   failing without consuming if the predicate does not match.-satisfies :: e -> (t -> Bool) -> Parser t e t-satisfies xe p- = Parser $ \ts- -> case ts of-        []              -> ParseSkip    (Bag.singleton (Blocker ts xe))-        t : ts'-         | p t          -> ParseSuccess t ts'-         | otherwise    -> ParseSkip    (Bag.singleton (Blocker ts xe))----- | Consume the first input token if it is accepted by the given match---   function. Fail without consuming if there is no match.-from :: e -> (t -> Maybe a) -> Parser t e a-from xe accept- = Parser $ \ts- -> case ts of-        []              -> ParseSkip    (Bag.singleton (Blocker ts xe))-        t : ts'-         -> case accept t of-               Just x   -> ParseSuccess x ts'-               Nothing  -> ParseSkip    (Bag.singleton (Blocker ts xe))----- | Given two parsers, try the first and if it succeeds produce---   the output of that parser, if not try the second.-alt :: Parser t e a -> Parser t e a -> Parser t e a-alt parserA parserB- = alts (parserA : parserB : [])----- | Like 'alt' but take a list of parser, trying them in order.-alts :: [Parser t e a] -> Parser t e a-alts parsers- = Parser $ \ts0- -> go ts0 (False, Nothing) (Bag.nil, Bag.nil) parsers- where-        go _   (False, Nothing)  (bsSkip, _bsFail) []-         = ParseSkip    bsSkip--        go _   (False, (Just x)) (bsSkip, _bsFail) []-         = ParseReturn  bsSkip x--        go _   (True,  _)        (_bsSkip, bsFail) []-         = ParseFailure bsFail--        go ts0 (failed, mx)      (bsSkip, bsFail) (p : ps)-         = case parse p ts0 of-            ParseSkip    bs1-             -> go ts0 (failed, mx)     (Bag.union bsSkip bs1, bsFail) ps--            ParseFailure bs1-             -> go ts0 (True,   mx)     (bsSkip, Bag.union bsFail bs1) ps--            ParseReturn  bs1 x-             -> go ts0 (failed, Just x) (Bag.union bsSkip bs1, bsFail) ps--            ParseSuccess x ts1-             -> ParseSuccess  x ts1----- Derived ----------------------------------------------------------------------- Parsers derived from the primitive ones.---- | Parse zero or more things, yielding a list of those things.-some :: Parser t e a -> Parser t e [a]-some parserA- = alt (do-        x       <- parserA-        xs      <- some parserA-        return  $ x : xs)-       (return [])----- | Parse one or more things, yielding a list of those things.-many :: Parser t e a -> Parser t e [a]-many parserA- = do   x       <- parserA-        xs      <- some parserA-        return  $ x : xs----- | Parse some things separated by other things.-sepBy   :: Parser t e a -> Parser t e s -> Parser t e [a]-sepBy parserA parserS- = alt  (sepBy1 parserA parserS)-        (return [])----- | Parse at least one thing separated by other things.-sepBy1  :: Parser t e a -> Parser t e s -> Parser t e [a]-sepBy1 parserA parserS- = do   x       <- parserA-        alt-         (do    _s      <- parserS-                xs      <- sepBy1 parserA parserS-                return  $ x : xs)--         (do    return  $ x : [])----- | Run a parser, peeking at the starting and ending tokens.-withDelims :: Parser t e a -> Parser t e (t, a, t)-withDelims p- = do   kStart  <- peek-        x       <- p-        kEnd    <- peek-        return  (kStart, x, kEnd)--
− src/SMR/Source/Parser.hs 
@@ -1,351 +0,0 @@--module SMR.Source.Parser where-import SMR.Core.Exp.Base-import SMR.Source.Expected-import SMR.Source.Token-import SMR.Source.Lexer-import SMR.Data.Located--import Data.Text                        (Text)--import qualified SMR.Source.Parsec      as P-import qualified SMR.Data.Bag           as Bag-import qualified Data.Text              as Text---type Parser s p a-        = P.Parser (Located Token) (Expected (Located Token) s p) a----- Config ----------------------------------------------------------------------data Config s p-        = Config-        { configReadSym :: Text -> Maybe s-        , configReadPrm :: Text -> Maybe p }----- Interface -------------------------------------------------------------------parseDecls-        :: Config s p-        -> [Located Token]-        -> Either (ParseError (Located Token) (Expected (Located Token) s p))-                  [Decl s p]-parseDecls c ts- = case P.parse pDeclsEnd ts of-        P.ParseSkip    es       -> Left $ ParseError (Bag.toList es)-        P.ParseReturn  _ xx     -> Right xx-        P.ParseFailure bs       -> Left $ ParseError (Bag.toList bs)-        P.ParseSuccess xx _     -> Right xx- where-        pDeclsEnd-         = do   ds      <- pDecls c-                _       <- pEnd-                return ds------ | Parse a complete expression from the given list of tokens.-parseExp-        :: Config s p-        -> [Located Token]-        -> Either (ParseError (Located Token) (Expected (Located Token) s p))-                  (Exp s p)-parseExp c ts- = case P.parse pExpEnd ts of-        P.ParseSkip    es       -> Left $ ParseError (Bag.toList es)-        P.ParseReturn  _ xx     -> Right xx-        P.ParseFailure bs       -> Left $ ParseError (Bag.toList bs)-        P.ParseSuccess xx _     -> Right xx- where-        pExpEnd-         = do   x       <- pExp c-                _       <- pEnd-                return x----- Decl ------------------------------------------------------------------------pDecls  :: Config s p -> Parser s p [Decl s p]-pDecls c- =      P.some (pDecl c)---pDecl   :: Config s p -> Parser s p (Decl s p)-pDecl c- = P.alts- [ P.enterOn (pNameOfSpace SMac) ExContextDecl $ \name-    -> do psParam <- P.some pParam-          _       <- pPunc '='-          xBody   <- pExp c-          _       <- pPunc ';'-          if length psParam == 0-           then return (DeclMac name xBody)-           else return (DeclMac name $ XAbs psParam xBody)-- , P.enterOn (pNameOfSpace SSet) ExContextDecl $ \name-    -> do _       <- pPunc '='-          xBody   <- pExp c-          _       <- pPunc ';'-          return (DeclSet name xBody)- ]----- Exp -------------------------------------------------------------------------pExp :: Config s p -> Parser s p (Exp s p)-pExp c-        -- Abstraction.- = P.alts- [ do   _       <- pPunc '\\'-        psParam <- P.some pParam-        _       <- pPunc '.'-        xBody   <- pExp c-        return  $ XAbs  psParam xBody--        -- Substitution train.- , do   csTrain <- pTrain c-        _       <- pPunc '.'-        xBody   <- pExp c-        return  $  XSub (reverse csTrain) xBody--        -- Application possibly using '$'- , do   xHead   <- pExpApp c-        P.alt-            (do _       <- pPunc '$'-                xRest   <- pExp c-                return  $  XApp xHead [xRest])-            (return xHead)- ]----- | Parser for an application.-pExpApp :: Config s p -> Parser s p (Exp s p)-pExpApp c-        -- Application of a superprim.- = P.alts- [ do   nKey-         <- do  nKey'   <- pNameOfSpace SKey-                if       nKey' == Text.pack "box" then return KBox-                 else if nKey' == Text.pack "run" then return KRun-                 else P.fail--        xArg    <- pExpAtom c-        return $ XKey nKey xArg--        -- Application of some other expression.- , do   xFun    <- pExpAtom c-        xsArgs  <- P.some (pExpAtom c)-        case xsArgs of-         []  -> return $ xFun-         _   -> return $ XApp xFun xsArgs- ]----- | Parser for an atomic expression.-pExpAtom :: Config s p -> Parser s p (Exp s p)-pExpAtom c-        -- Parenthesised expression.- = P.alts- [ do   _       <- pPunc '('-        x       <- pExp c-        _       <- pPunc ')'-        return x--        -- Nominal variable.- , do   _ <- pPunc '?'-        n <- pNat-        return $ XRef (RNom n)--        -- Named variable with or without index.- , do   (space, name) <- pName--        case space of-         -- Named variable.-         SVar-          -> P.alt (do  _       <- pPunc '^'-                        ix      <- pNat-                        return  $ XVar name ix)-                   (return $ XVar name 0)--         -- Named macro.-         SMac -> return $ XRef (RMac name)--         -- Named set.-         SSet -> return $ XRef (RSet name)--         -- Named symbol-         SSym-          -> case configReadSym c name of-                Just s  -> return (XRef (RSym s))-                Nothing -> P.fail--         -- Named primitive.-         SPrm-          -> case configReadPrm c name of-                Just p  -> return (XRef (RPrm p))-                Nothing -> P.fail--         -- Named keyword.-         SKey -> P.fail--         -- Named nominal (should be handled above)-         SNom -> P.fail- ]----- Param ------------------------------------------------------------------------- | Parser for a function parameter.-pParam  :: Parser s p Param-pParam- = P.alts- [ do   _       <- pPunc '!'-        n       <- pNameOfSpace SVar-        return  $  PParam n PVal-- , do   _       <- pPunc '~'-        n       <- pNameOfSpace SVar-        return  $  PParam n PExp-- , do   n       <- pNameOfSpace SVar-        return  $  PParam n PVal-- ]----- Train ------------------------------------------------------------------------- | Parser for a substitution train.---   The cars are produced in reverse order.-pTrain  :: Config s p -> Parser s p [Car s p]-pTrain c- = do   cCar    <- pTrainCar c-        P.alt-         (do csCar <- pTrain c-             return $ cCar : csCar)-         (do return $ cCar : [])----- | Parse a single car in the train.-pTrainCar :: Config s p -> Parser s p (Car s p)-pTrainCar c- = P.alt-        -- Substitution, both simultaneous and recursive-    (do car     <- pCarSimRec c-        return car)--    (do -- An ups car.-        ups     <- pUps-        return (CUps ups))----- Snv --------------------------------------------------------------------------- | Parser for a substitution environment.------   Snv   ::= '[' Bind*, ']'----pCarSimRec :: Config s p -> Parser s p (Car s p)-pCarSimRec c- = do   _       <- pPunc '['--        P.alt   -- Recursive substitution.-         (do    _       <- pPunc '['-                bs      <- P.sepBy (pBind c) (pPunc ',')-                _       <- pPunc ']'-                _       <- pPunc ']'-                return  $ CRec (SSnv (reverse bs)))--                -- Simultaneous substitution.-         (do    bs      <- P.sepBy (pBind c) (pPunc ',')-                _       <- pPunc ']'-                return  $ CSim (SSnv (reverse bs)))----- | Parser for a binding.------   Bind ::= Name '=' Exp---         |  Name '^' Nat '=' Exp----pBind   :: Config s p -> Parser s p (SnvBind s p)-pBind c- = P.alt-        (P.enterOn (pNameOfSpace SVar) ExContextBind $ \name-         -> P.alt-                (do _       <- pPunc '='-                    x       <- pExp c-                    return  $ BindVar name 0 x)--                (do _       <- pPunc '^'-                    bump    <- pNat-                    _       <- pPunc '='-                    x       <- pExp c-                    return  $ BindVar name bump x))--        (do pPunc '?'-            ix <- pNat-            _  <- pPunc '='-            x  <- pExp c-            return $ BindNom ix x)----- Ups --------------------------------------------------------------------------- | Parser for an ups.------   Ups  ::= '{' Bump*, '}'----pUps :: Parser s p Ups-pUps- = do   _       <- pPunc '{'-        bs      <- P.sepBy pBump (pPunc ',')-        _       <- pPunc '}'-        return  $ UUps (reverse bs)----- | Parser for a bump.------   Bump ::= Name ':' Nat---         |  Name '^' Nat ':' Nat----pBump :: Parser s p UpsBump-pBump- = do   name    <- pNameOfSpace SVar-        P.alt-         (do    _       <- pPunc ':'-                inc     <- pNat-                return  ((name, 0), inc))--         (do    _       <- pPunc '^'-                depth   <- pNat-                _       <- pPunc ':'-                inc     <- pNat-                return  ((name, depth), inc))------------------------------------------------------------------------------------- | Parser for a natural number.-pNat :: Parser s p Integer-pNat- = P.from ExBaseNat (takeNatOfToken . valueOfLocated)----- | Parser for a name in the given space.-pNameOfSpace :: Space -> Parser s p Text-pNameOfSpace s- = P.from (ExBaseNameOf s) (takeNameOfToken s . valueOfLocated)----- | Parser for a name of any space.-pName :: Parser s p (Space, Text)-pName- = P.from ExBaseNameAny    (takeAnyNameOfToken . valueOfLocated)----- | Parser for the end of input token.-pEnd  :: Parser s p ()-pEnd- = do   _ <- P.satisfies ExBaseEnd (isToken KEnd . valueOfLocated)-        return ()----- | Parser for a punctuation character.-pPunc  :: Char -> Parser s p ()-pPunc c- = do   _ <- P.satisfies (ExBasePunc c) (isToken (KPunc c) . valueOfLocated)-        return ()-
− src/SMR/Source/Pretty.hs 
@@ -1,200 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module SMR.Source.Pretty where-import SMR.Core.Exp.Base-import SMR.Prim.Name-import SMR.Prim.Op.Base-import Data.Monoid-import Data.Text                                (Text)-import Data.Text.Lazy.Builder                   (Builder)-import qualified Data.Text.Lazy.Builder         as B----- Class ------------------------------------------------------------------------- | Class of things that can be converted to text builders.-class Build a where- build  :: a -> Builder--instance Build Text where- build tx = B.fromText tx--instance Build Prim where- build pp = buildPrim pp----- | Context we're currently in when pretty printing.-data Ctx-        = CtxTop        -- ^ Top level context.-        | CtxFun        -- ^ Functional expression in an an application.-        | CtxArg        -- ^ Argument expression in an application.-        deriving Show----- | Wrap a thing in parenthesis.-parens :: Builder -> Builder-parens bb- = "(" <> bb <> ")"----- Decl -------------------------------------------------------------------------- | Yield a builder for a declaration.-buildDecl-        :: (Build s, Build p)-        => Decl s p -> Builder-buildDecl dd- = case dd of-        DeclMac n xx-         -> "@" <> B.fromText n <> " = " <> buildExp CtxTop xx <> ";\n"--        DeclSet n xx-         -> "+" <> B.fromText n <> " = " <> buildExp CtxTop xx <> ";\n"----- Exp --------------------------------------------------------------------------- | Yield a builder for an expression.-buildExp-        :: (Build s, Build p)-        => Ctx -> Exp s p -> Builder-buildExp ctx xx- = case xx of-        XRef r    -> buildRef r--        XVar n 0  -> B.fromText n-        XVar n d  -> B.fromText n <> "^" <> B.fromString (show d)--        XKey k1 x2-         -> let ppExp   = buildKey k1 <> " " <> buildExp CtxArg x2-            in  case ctx of-                 CtxArg -> parens ppExp-                 _      -> ppExp--        XApp x1 xs2-         -> let ppExp   =  buildExp CtxFun x1 <> " " <> go xs2-                go []               = ""-                go (x : [])         = buildExp CtxArg x-                go (x11 : x21 : xs) = buildExp CtxArg x11 <> " " <> go (x21 : xs)-            in case ctx of-                CtxArg  -> parens ppExp-                _       -> ppExp--        XAbs vs x-         -> let go []        = "."-                go (p1 : []) = buildParam p1 <> "."-                go (p1 : ps) = buildParam p1 <> " " <> go ps-                ss           = "\\" <> go vs <> buildExp CtxTop x-            in  case ctx of-                 CtxArg -> parens ss-                 CtxFun -> parens ss-                 _      -> ss--        XSub train x-         |  length train == 0-         -> buildExp ctx x-         |  otherwise-         -> let ss     = buildTrain train <> "." <> buildExp CtxTop x-            in  case ctx of-                 CtxArg  -> parens ss-                 CtxFun  -> parens ss-                 _       -> ss----- | Yield a builder for a parameter.-buildParam :: Param -> Builder-buildParam pp- = case pp of-        PParam n PVal    -> B.fromText n-        PParam n PExp    -> "~" <> B.fromText n----- | Yield a builder for a keyword.-buildKey :: Key -> Builder-buildKey kk- = case kk of-        KBox    -> "##box"-        KRun    -> "##run"----- Train ------------------------------------------------------------------------- | Yield a builder for a train.-buildTrain  :: (Build s, Build p) => Train s p -> Builder-buildTrain cs0- = go cs0- where  go []           = ""-        go (c : cs)     = go cs <> buildCar c----- | Yield a builder for a train car.-buildCar :: (Build s, Build p) => Car s p -> Builder-buildCar cc- = case cc of-        CSim snv        -> buildSnv snv-        CRec snv        -> "[" <> buildSnv snv <> "]"-        CUps ups        -> buildUps ups----- Snv --------------------------------------------------------------------------- | Yield a builder for a substitution.-buildSnv  :: (Build s, Build p) => Snv s p -> Builder-buildSnv (SSnv vs)- = "[" <> go (reverse vs) <> "]"- where  go []   = ""-        go (b : [])     = buildSnvBind b-        go (b : bs)     = buildSnvBind b <> ", " <> go bs----- | Yield a builder for a substitution binding.-buildSnvBind :: (Build s, Build p) => SnvBind s p -> Builder-buildSnvBind (BindVar name bump xx)- | bump == 0- = B.fromText name- <> "=" <> buildExp CtxTop xx-- | otherwise- =  B.fromText name <> "^" <> B.fromString (show bump)- <> "=" <> buildExp CtxTop xx--buildSnvBind (BindNom ix xx)- =  "?" <> B.fromString (show ix)- <> "=" <> buildExp CtxTop xx----- Ups --------------------------------------------------------------------------- | Yield a builder for an ups.-buildUps :: Ups -> Builder-buildUps (UUps vs)- = "{" <> go (reverse vs) <> "}"- where  go []   = ""-        go (b : [])     = buildUpsBump b-        go (b : bs)     = buildUpsBump b <> ", " <> go bs----- | Yield a builder for an ups bump.-buildUpsBump :: UpsBump -> Builder-buildUpsBump ((name, bump), inc)- | bump == 0- = B.fromText name- <> "=" <> B.fromString (show inc)-- | otherwise- =  B.fromText name <> "^" <> B.fromString (show bump)- <> "=" <> B.fromString (show inc)----- Ref --------------------------------------------------------------------------- | Yield a builder for a reference.-buildRef :: (Build s, Build p) => Ref s p -> Builder-buildRef rr- = case rr of-        RMac n  -> "@" <> B.fromText n-        RSet n  -> "+" <> B.fromText n-        RSym s  -> "%" <> build s-        RPrm p  -> "#" <> build p-        RNom i  -> "?" <> B.fromString (show i)----- Prim -------------------------------------------------------------------------- | Yield a builder for a primitive.-buildPrim :: Prim -> Builder-buildPrim pp- = B.fromText $ pprPrim pp--
− src/SMR/Source/Token.hs 
@@ -1,65 +0,0 @@--module SMR.Source.Token where-import Data.Text (Text)----- | Tokens for for the source language.-data Token-        = KEnd                  -- ^ End of input.-        | KPunc Char            -- ^ Punctuation character.-        | KName Space Text      -- ^ A scoped name.-        | KNat  Integer         -- ^ A natural number.-        deriving (Show, Eq)----- | Name space of a name.-data Space-        = SVar                  -- ^ Local variable.-        | SMac                  -- ^ Macro name.-        | SSym                  -- ^ Symbol name.-        | SSet                  -- ^ Set name.-        | SPrm                  -- ^ Primitive name.-        | SKey                  -- ^ Keyword (super primitive)-        | SNom                  -- ^ Nominal name.-        deriving (Show, Eq)----- | Check if a token is equal to the give none.-isToken :: Token -> Token -> Bool-isToken k1 k2 = k1 == k2----- | Check is token is punctuation using the given character.-isKPunc :: Char -> Token -> Bool-isKPunc c k- = case k of-        KPunc c' -> c == c'-        _        -> False----- | Take the name from a token, if any.-takeNameOfToken :: Space -> Token -> Maybe Text-takeNameOfToken ss1 kk- = case kk of-        KName ss2 n-         | ss1 == ss2   -> Just n-         | otherwise    -> Nothing-        _               -> Nothing----- | Take the name from a token, if any.-takeAnyNameOfToken :: Token -> Maybe (Space, Text)-takeAnyNameOfToken kk- = case kk of-        KName ss2 n     -> Just (ss2, n)-        _               -> Nothing----- | Take the natural number from a token, if any.-takeNatOfToken :: Token -> Maybe Integer-takeNatOfToken kk- = case kk of-        KNat n          -> Just n-        _               -> Nothing--