Fix deltaparsing

pact.cabal

@@ -382,6 +382,7 @@ test-suite hspec
     RoundTripSpec
     PrincipalSpec
     SizeOfSpec
+    Test.Pact.Parse
 
   if !impl(ghcjs)
     other-modules:
@@ -447,6 +448,7 @@ test-suite hspec
         , sbv
         , servant-client
         , temporary >=1.3
+        , trifecta
         , yaml
         , process
         , posix-pty

src/Pact/Compile.hs

@@ -151,13 +151,15 @@ reservedAtom = bareAtom >>= \AtomExp{..} -> case HM.lookup _atomAtom reserveds o
   Just r -> commit >> return r
 
 compile :: ParseEnv -> MkInfo -> Exp Parsed -> Either PactError (Term Name)
-compile pe mi e = let ei = mi <$> e in runCompile pe topLevel (initParseState ei) ei
+compile pe mi e = runCompile pe topLevel (initParseState ei) ei
+ where
+  ei = mi <$> e
 
 compileExps :: Traversable t => ParseEnv -> MkInfo -> t (Exp Parsed) -> Either PactError (t (Term Name))
-compileExps pe mi exps = sequence $ compile pe mi <$> exps
+compileExps pe mi exps = mapM (compile pe mi) exps
 
 moduleState :: Compile ModuleState
-moduleState = use (psUser . csModule) >>= \m -> case m of
+moduleState = use (psUser . csModule) >>= \case
   Just m' -> return m'
   Nothing -> context >>= tokenErr' "Must be declared within module"
 
@@ -213,7 +215,7 @@ cToTV n | n < 26 = fromString [toC n]
   where toC i = toEnum (fromEnum 'a' + i)
 
 
-sexp :: (Compile a) -> Compile a
+sexp :: Compile a -> Compile a
 sexp body = withList' Parens (body <* eof)
 
 specialFormOrApp :: (Reserved -> Compile (Compile (Term Name))) -> Compile (Term Name)
@@ -246,7 +248,7 @@ valueLevel = literals <|> varAtom <|> specialFormOrApp valueLevelForm where
     _ -> expected "value level form (let, let*, with-capability, cond)"
 
 moduleLevel :: Compile [Term Name]
-moduleLevel = specialForm $ \r -> case r of
+moduleLevel = specialForm $ \case
     RUse -> returnl useForm
     RDefconst -> returnl defconst
     RBless -> return (bless >> return [])
@@ -411,7 +413,7 @@ meta modelAllowed =
       ModelAllowed -> a
       ModelNotAllowed -> unexpected' "@model not allowed in this declaration"
     atPairs = do
-      ps <- sort <$> (some (docPair <|> modelPair))
+      ps <- sort <$> some (docPair <|> modelPair)
       case ps of
         [DocPair doc] -> return (Meta (Just doc) [])
         [ModelPair es] -> whenModelAllowed $ return (Meta Nothing es)
@@ -447,7 +449,7 @@ defcapManaged dt = case dt of
   _ -> return Nothing
   where
     doDefcapMeta = symbol "@managed" *>
-      ((DMDefcap . DefcapManaged) <$> (doUserMgd <|> doAuto))
+      (DMDefcap . DefcapManaged <$> (doUserMgd <|> doAuto))
     doUserMgd = Just <$> ((,) <$> (_atomAtom <$> userAtom) <*> userVar)
     doAuto = pure Nothing
     doEvent = symbol "@event" *> pure (DMDefcap DefcapEvent)
@@ -458,7 +460,7 @@ defpact = do
   (defname,returnTy) <- first _atomAtom <$> typedAtom
   args <- withList' Parens $ many arg
   m <- meta ModelAllowed
-  (body,bi) <- bodyForm' $ specialForm $ \r -> case r of
+  (body,bi) <- bodyForm' $ specialForm $ \case
     RStep -> return step
     RStepWithRollback -> return stepWithRollback
     _ -> expected "step or step-with-rollback"
@@ -479,7 +481,7 @@ moduleForm = do
   modName' <- _atomAtom <$> userAtom
   gov <- Governance <$> ((Left <$> keysetNameStr) <|> (Right <$> userVar))
   m <- meta ModelAllowed
-  use (psUser . csModule) >>= \cm -> case cm of
+  use (psUser . csModule) >>= \case
     Just {} -> syntaxError "Invalid nested module or interface"
     Nothing -> return ()
   i <- contextInfo
@@ -504,7 +506,7 @@ interface :: Compile (Term Name)
 interface = do
   iname' <- _atomAtom <$> bareAtom
   m <- meta ModelAllowed
-  use (psUser . csModule) >>= \ci -> case ci of
+  use (psUser . csModule) >>= \case
     Just {} -> syntaxError "invalid nested interface or module"
     Nothing -> return ()
   info <- contextInfo
@@ -514,7 +516,7 @@ interface = do
       iname = ModuleName iname' Nothing
       ihash = ModuleHash . pactHash . encodeUtf8 . _unCode $ code
   (bd,ModuleState{..}) <- withModuleState (initModuleState iname ihash) $
-            bodyForm $ specialForm $ \r -> case r of
+            bodyForm $ specialForm $ \case
               RDefun -> return $ defSig Defun
               RDefconst -> return defconst
               RUse -> return useForm

src/Pact/Parse.hs

@@ -35,7 +35,6 @@ import Control.DeepSeq (NFData)
 import Control.Lens (Wrapped(..))
 import Control.Monad
 import qualified Data.Aeson as A
-import qualified Data.Attoparsec.Text as AP
 import qualified Data.ByteString as BS
 import Data.Char (digitToInt)
 import Data.Decimal
@@ -55,6 +54,8 @@ import Pact.Types.Pretty (Pretty(..),viaShow)
 import Pact.Types.Info
 import Pact.Types.Term (ToTerm)
 
+-- -------------------------------------------------------------------------- --
+-- Expression Parser
 
 
 -- | Main parser for Pact expressions.
@@ -63,6 +64,7 @@ expr = do
   delt <- position
   let inf = do
         end <- position
+        -- let len = column end - column delt
         let len = bytes end - bytes delt
         return $! Parsed delt (fromIntegral len)
       separator t s = symbol t >> (ESeparator . SeparatorExp s <$> inf)
@@ -141,7 +143,7 @@ newtype ParsedDecimal = ParsedDecimal Decimal
 
 instance A.FromJSON ParsedDecimal where
   parseJSON (A.String s) =
-    ParsedDecimal <$> case AP.parseOnly (unPactParser number) s of
+    ParsedDecimal <$> case pactAttoParseOnly (unPactParser number) s of
                         Right (LDecimal d) -> return d
                         Right (LInteger i) -> return (fromIntegral i)
                         _ -> fail $ "Failure parsing decimal string: " ++ show s
@@ -167,7 +169,7 @@ newtype ParsedInteger = ParsedInteger Integer
 
 instance A.FromJSON ParsedInteger where
   parseJSON (A.String s) =
-    ParsedInteger <$> case AP.parseOnly (unPactParser number) s of
+    ParsedInteger <$> case pactAttoParseOnly (unPactParser number) s of
                         Right (LInteger i) -> return i
                         _ -> fail $ "Failure parsing integer string: " ++ show s
   parseJSON (A.Number n) = return $ ParsedInteger (round n)
@@ -181,16 +183,19 @@ instance A.ToJSON ParsedInteger where
 
 instance Wrapped ParsedInteger
 
+-- -------------------------------------------------------------------------- --
+-- Top Level Parsers
+
 -- | "Production" parser: atto, parse multiple exprs.
 parseExprs :: Text -> Either String [Exp Parsed]
-parseExprs = AP.parseOnly (unPactParser (whiteSpace *> exprs <* TF.eof))
+parseExprs = pactAttoParseOnly (unPactParser (whiteSpace *> exprs <* TF.eof))
 {-# INLINABLE parseExprs #-}
 
 -- | Legacy version of "production" parser: atto, parse multiple exprs. This
 -- parser does not force EOF and thus accepts trailing inputs that are not valid
 -- pact code.
 legacyParseExprs :: Text -> Either String [Exp Parsed]
-legacyParseExprs = AP.parseOnly (unPactParser (whiteSpace *> exprs))
+legacyParseExprs = pactAttoParseOnly (unPactParser (whiteSpace *> exprs))
 {-# INLINABLE legacyParseExprs #-}
 
 -- | ParsedCode version of 'parseExprs'
@@ -210,7 +215,6 @@ _parseF p fp = do
   let s = unpack $ decodeUtf8 bs
   fmap (,s) <$> TF.parseFromFileEx p fp
 
-
 _parseS :: String -> TF.Result [Exp Parsed]
 _parseS = TF.parseString exprsOnly mempty
 

src/Pact/Types/ExpParser.hs

@@ -61,7 +61,6 @@ import Control.Monad.State
 import Control.Monad.Reader
 import Control.Arrow (second)
 import Prelude hiding (exp)
-import Data.String
 import Control.Lens hiding (prism)
 import Data.Default
 import Data.Text (Text,unpack)
@@ -108,7 +107,7 @@ data ParseState a = ParseState
 makeLenses ''ParseState
 
 -- | Current env has flag for try-narrow fix.
-data ParseEnv = ParseEnv
+newtype ParseEnv = ParseEnv
     { _peNarrowTry :: Bool }
 instance Default ParseEnv where def = ParseEnv True
 
@@ -120,13 +119,16 @@ mkEmptyInfo e = Info (Just (mempty,e))
 
 {-# INLINE mkStringInfo #-}
 mkStringInfo :: String -> MkInfo
-mkStringInfo s d = Info (Just (fromString $ take (_pLength d) $
-                               drop (fromIntegral $ TF.bytes d) s,d))
+mkStringInfo = mkTextInfo . T.pack
 
 {-# INLINE mkTextInfo #-}
 mkTextInfo :: T.Text -> MkInfo
-mkTextInfo s d = Info (Just (Code $ T.take (_pLength d) $
-                             T.drop (fromIntegral $ TF.bytes d) s,d))
+mkTextInfo s d = Info $ Just (Code code, d)
+  where
+    code = T.take len $ T.drop offset s
+    -- offset = fromIntegral $ TF.column (_pDelta d)
+    offset = fromIntegral $ TF.bytes (_pDelta d)
+    len = _pLength d
 
 type ExpParse s a = ReaderT ParseEnv (StateT (ParseState s) (Parsec Void Cursor)) a
 

src/Pact/Types/Info.hs

@@ -71,7 +71,6 @@ instance Arbitrary Parsed where
         , Directed <$> genFilename <*> genPositiveInt64 <*> genPositiveInt64 <*> genPositiveInt64 <*> genPositiveInt64 ]
 instance NFData Parsed
 instance Default Parsed where def = Parsed mempty 0
-instance HasBytes Parsed where bytes = bytes . _pDelta
 instance Pretty Parsed where pretty = pretty . _pDelta
 
 
@@ -103,7 +102,7 @@ instance Default Info where def = Info Nothing
 instance SizeOf Info where
   sizeOf _ _ = 0
 
--- make an Info that refers to the indicated text
+-- | Make an Info that refers to the indicated text
 mkInfo :: Text -> Info
 mkInfo t = Info $ Just (Code t,Parsed delt len)
   where len = T.length t

src/Pact/Types/Orphans.hs

@@ -1,10 +1,8 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 -- |
 -- Module      :  Pact.Types.Orphans
@@ -19,10 +17,7 @@ module Pact.Types.Orphans where
 import Data.Serialize
 import Data.Decimal
 import qualified Data.Aeson as A
-import Text.Trifecta.Combinators (DeltaParsing(..))
 import Text.Trifecta.Delta
-import qualified Data.Attoparsec.Text as AP
-import qualified Data.Attoparsec.Internal.Types as APT
 import Data.Text (Text)
 import Data.Text.Encoding
 import Pact.Time.Internal (NominalDiffTime(..), UTCTime(..))
@@ -53,20 +48,6 @@ instance Serialize A.Value where
 
 instance NFData Delta
 
-
--- | Atto DeltaParsing instance provides 'position' only (with no support for
--- hidden chars like Trifecta).
-instance DeltaParsing AP.Parser where
-    line = return mempty
-    position = attoPos >>= \(APT.Pos p) -> let p' = fromIntegral p in return $ Columns p' p'  -- p p
-    slicedWith f a = (`f` mempty) <$> a
-    rend = return mempty
-    restOfLine = return mempty
-
--- | retrieve pos from Attoparsec.
-attoPos :: APT.Parser n APT.Pos
-attoPos = APT.Parser $ \t pos more _lose win -> win t pos more pos
-
 instance Default Text where def = ""
 instance Serialize Text where
   put = put . encodeUtf8