diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,90 @@ + +module Main where +import qualified SMR.CLI.Config as Config +import qualified SMR.CLI.Repl as Repl +import qualified SMR.CLI.Driver.Load as Driver +import qualified SMR.Core.World as World +import qualified SMR.Source.Pretty as Source +import qualified SMR.Core.Codec as Codec +import qualified SMR.Core.Codec as Codec + +import qualified Foreign.Marshal.Alloc as Foreign + +import qualified System.Environment as System +import qualified System.FilePath as System +import qualified System.IO as System +import qualified Data.Text.Lazy.IO as TL +import qualified Data.Text.Lazy.Builder as BL +import qualified Data.Maybe as Maybe +import Data.Monoid + +------------------------------------------------------------------------------- +main :: IO () +main + = do args <- System.getArgs + config <- Config.parseArgs args Config.configZero + + case Config.configMode config of + Config.ModeNone + -> runRepl Nothing + + Config.ModeREPL mFile + -> runRepl mFile + + Config.ModeLoad file + -> runLoad file + + Config.ModeConvert file1 file2 + -> runConvert file1 file2 + + +------------------------------------------------------------------------------- +runRepl :: Maybe FilePath -> IO () +runRepl mPath + = do world <- World.newWorld () + Repl.replStart + $ Repl.State + { Repl.stateMode = Repl.ModeNone + , Repl.stateDecls = [] + , Repl.stateFiles = Maybe.maybeToList mPath + , Repl.stateWorld = world } + + +------------------------------------------------------------------------------- +runLoad :: FilePath -> IO () +runLoad path + = do decls <- Driver.runLoadFileDecls path + TL.putStr + $ BL.toLazyText + $ mconcat + $ [Source.buildDecl d <> BL.fromString "\n" | d <- decls] + + +------------------------------------------------------------------------------- +runConvert :: FilePath -> FilePath -> IO () +runConvert pathSrc pathDst + -- Encode text shimmer file to binary store. + | System.takeExtension pathSrc == ".smr" + , System.takeExtension pathDst == ".sms" + = do + decls <- Driver.runLoadFileDecls pathSrc + let len = Codec.sizeOfFileDecls decls + Foreign.allocaBytes len $ \pBuf + -> do _ <- Codec.pokeFileDecls decls pBuf + h <- System.openBinaryFile pathDst System.WriteMode + System.hPutBuf h pBuf len + System.hClose h + return () + + -- | Decode binary store to text shimmer file. + | System.takeExtension pathSrc == ".sms" + , System.takeExtension pathDst == ".smr" + = do decls <- Driver.runLoadFileDecls pathSrc + TL.writeFile pathDst + $ BL.toLazyText + $ mconcat + $ [ Source.buildDecl d <> BL.fromString "\n" | d <- decls] + + | otherwise + = error "runConvert: cannot convert" + diff --git a/SMR/CLI/Driver/Load.hs b/SMR/CLI/Driver/Load.hs --- a/SMR/CLI/Driver/Load.hs +++ b/SMR/CLI/Driver/Load.hs @@ -6,9 +6,10 @@ 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 qualified SMR.Core.Codec as Codec import SMR.Core.Exp (Decl) import SMR.Prim.Op.Base (Prim) +import qualified Data.ByteString as BS import qualified Foreign.Marshal.Alloc as Foreign @@ -38,16 +39,14 @@ Right decls -> return decls - -- Shimmer binary store file. - | System.takeExtension path == ".sms" + -- Somee other file. + | otherwise = 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 + bs <- BS.readFile path - | otherwise - = error "runLoadFileDecls: cannot load this file" + let magicSMR = BS.pack [0x53, 0x4d, 0x52, 0x31] + when (not $ BS.isPrefixOf magicSMR (BS.take 4 bs)) + $ error "runLoadFileDecls: cannot load this file" + + return $ Codec.unpackFileDecls bs + diff --git a/SMR/Core/Codec.hs b/SMR/Core/Codec.hs --- a/SMR/Core/Codec.hs +++ b/SMR/Core/Codec.hs @@ -1,4 +1,3 @@ - -- | Utilities for working with binary encoded Shimmer trees. -- -- The grammar for the binary format is as follows: @@ -121,6 +120,7 @@ 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. diff --git a/SMR/Core/Codec/Size.hs b/SMR/Core/Codec/Size.hs --- a/SMR/Core/Codec/Size.hs +++ b/SMR/Core/Codec/Size.hs @@ -8,7 +8,9 @@ import SMR.Core.Exp import SMR.Prim.Op.Base import qualified Data.Text as T +import qualified Data.Text.Encoding as T import qualified Data.Text.Foreign as T +import qualified Data.ByteString as BS --------------------------------------------------------------------------------------------------- @@ -135,7 +137,11 @@ sizeOfName :: Text -> Int sizeOfName tt = result - where n = T.lengthWord16 tt + where -- There doesn't seem to be to get the encoded length + -- of a string from the text library other than actually + -- encoding it. + n = BS.length $ T.encodeUtf8 tt + result | n < 13 = 1 + n | n < 2^(8 :: Int) = 1 + 1 + n @@ -158,7 +164,7 @@ sizeOfList :: (a -> Int) -> [a] -> Int sizeOfList fs xs = result - where n = length xs + where n = length xs result | n < 13 = 1 + sum (map fs xs) | n < 2^(8 :: Int) = 1 + 1 + sum (map fs xs) diff --git a/SMR/Source/Pretty.hs b/SMR/Source/Pretty.hs --- a/SMR/Source/Pretty.hs +++ b/SMR/Source/Pretty.hs @@ -23,8 +23,14 @@ instance Build Prim where build pp = buildPrim pp +instance (Build s, Build p) => Build (Decl s p) where + build xx = buildDecl xx + instance (Build s, Build p) => Build (Exp s p) where build xx = buildExp CtxTop xx + +instance (Build s, Build p) => Build (Ref s p) where + build xx = buildRef xx -- | Context we're currently in when pretty printing. diff --git a/shimmer.cabal b/shimmer.cabal --- a/shimmer.cabal +++ b/shimmer.cabal @@ -1,5 +1,5 @@ name: shimmer -version: 0.1.2 +version: 0.1.3.1 license: MIT license-file: LICENSE author: Ben Lippmeier @@ -10,21 +10,44 @@ description: The Reflective Lambda Machine synopsis: The Reflective Lambda Machine -library +executable shimmer + build-depends: + base >= 4.10 && < 4.11, + text >= 1.2 && < 1.3, + containers >= 0.5 && < 0.6, + bytestring >= 0.10 && < 0.11, + filepath >= 1.4.0 && < 1.5, + haskeline >= 0.7 && < 0.8 + ghc-options: -O2 + main-is: + Main.hs + + extensions: + PatternGuards + OverloadedStrings + + other-modules: + SMR.CLI.Driver.Load + SMR.CLI.Config + SMR.CLI.Help + SMR.CLI.Repl + +library build-depends: base >= 4.10 && < 4.11, text >= 1.2 && < 1.3, - vector >= 0.12 && < 0.13, containers >= 0.5 && < 0.6, bytestring >= 0.10 && < 0.11, filepath >= 1.4.0 && < 1.5, haskeline >= 0.7 && < 0.8 - exposed-modules: + ghc-options: + -O2 + exposed-modules: SMR.Core.Codec SMR.Core.Exp SMR.Core.Step @@ -43,11 +66,6 @@ SMR.Source.Token other-modules: - SMR.CLI.Driver.Load - SMR.CLI.Config - SMR.CLI.Help - SMR.CLI.Repl - SMR.Core.Codec.Peek SMR.Core.Codec.Poke SMR.Core.Codec.Size