From 936f8fcc87b81cf8f9c655e00ceed6a1192d025d Mon Sep 17 00:00:00 2001 From: Anton-Latukha Date: Wed, 19 Jan 2022 15:58:28 +0200 Subject: [PATCH] treewide: migrate to use of N{Pos,SourcePos} This is work towards: https://github.com/haskell-nix/hnix/issues/1026 & #746. --- src/Nix/Builtins.hs | 2 +- src/Nix/Convert.hs | 11 ++-- src/Nix/Eval.hs | 23 +++++---- src/Nix/Expr/Types.hs | 89 ++++++++++++++++++--------------- src/Nix/Expr/Types/Annotated.hs | 19 +++---- src/Nix/Parser.hs | 8 +-- src/Nix/Reduce.hs | 2 +- src/Nix/Render.hs | 9 ++-- src/Nix/Render/Frame.hs | 4 +- tests/ParserTests.hs | 2 +- tests/PrettyParseTests.hs | 19 ++++--- 11 files changed, 95 insertions(+), 93 deletions(-) diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs index 731b84e88..1998de49a 100644 --- a/src/Nix/Builtins.hs +++ b/src/Nix/Builtins.hs @@ -1986,7 +1986,7 @@ builtinsList = , add Normal "tail" tailNix , add2 Normal "toFile" toFileNix , add Normal "toJSON" toJSONNix - , add Normal "toPath" toPathNix + , add Normal "toPath" toPathNix -- Deprecated in Nix: https://github.com/NixOS/nix/pull/2524 , add Normal "toXML" toXMLNix , add0 Normal "true" (pure $ mkNVBool True) , add Normal "tryEval" tryEvalNix diff --git a/src/Nix/Convert.hs b/src/Nix/Convert.hs index 4ad3944b0..2bc890d30 100644 --- a/src/Nix/Convert.hs +++ b/src/Nix/Convert.hs @@ -21,7 +21,6 @@ import qualified Data.HashMap.Lazy as M import Nix.Atoms import Nix.Effects import Nix.Expr.Types -import Nix.Expr.Types.Annotated import Nix.Frames import Nix.String import Nix.Value @@ -410,11 +409,11 @@ instance Convertible e t f m toValue = toValue @Path . coerce instance Convertible e t f m - => ToValue SourcePos m (NValue' t f m (NValue t f m)) where - toValue (SourcePos f l c) = do - f' <- toValue $ mkNixStringWithoutContext $ fromString f - l' <- toValue $ unPos l - c' <- toValue $ unPos c + => ToValue NSourcePos m (NValue' t f m (NValue t f m)) where + toValue (NSourcePos f l c) = do + f' <- toValue $ mkNixStringWithoutContext $ fromString $ coerce f + l' <- toValue $ unPos $ coerce l + c' <- toValue $ unPos $ coerce c let pos = M.fromList [("file" :: VarName, f'), ("line", l'), ("column", c')] pure $ mkNVSet' mempty pos diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs index 2728ca1d5..890f9891d 100644 --- a/src/Nix/Eval.hs +++ b/src/Nix/Eval.hs @@ -213,7 +213,7 @@ attrSetAlter :: forall v m . MonadNixEval v m => [VarName] - -> SourcePos + -> NSourcePos -> AttrSet (m v) -> PositionSet -> m v @@ -267,7 +267,7 @@ desugarBinds embed = (`evalState` mempty) . traverse (findBinding <=< collect) collect :: Binding r -> State - (AttrSet (SourcePos, [Binding r])) + (AttrSet (NSourcePos, [Binding r])) (Either VarName (Binding r)) collect (NamedVar (StaticKey x :| y : ys) val oldPosition) = do @@ -275,24 +275,24 @@ desugarBinds embed = (`evalState` mempty) . traverse (findBinding <=< collect) pure $ Left x where updateBindingInformation - :: AttrSet (SourcePos, [Binding r]) - -> AttrSet (SourcePos, [Binding r]) + :: AttrSet (NSourcePos, [Binding r]) + -> AttrSet (NSourcePos, [Binding r]) updateBindingInformation = M.insert x =<< maybe (mkBindingSingleton oldPosition) (\ (foundPosition, newBindings) -> second (<> newBindings) $ mkBindingSingleton foundPosition) . M.lookup x - mkBindingSingleton :: SourcePos -> (SourcePos, [Binding r]) + mkBindingSingleton :: NSourcePos -> (NSourcePos, [Binding r]) mkBindingSingleton np = (np , one $ bindValAt np) where - bindValAt :: SourcePos -> Binding r + bindValAt :: NSourcePos -> Binding r bindValAt = NamedVar (y :| ys) val collect x = pure $ pure x findBinding :: Either VarName (Binding r) - -> State (AttrSet (SourcePos, [Binding r])) (Binding r) + -> State (AttrSet (NSourcePos, [Binding r])) (Binding r) findBinding = either (\ x -> @@ -320,7 +320,7 @@ evalBinds isRecursive binds = where buildResult :: Scopes m v - -> [([VarName], SourcePos, m v)] + -> [([VarName], NSourcePos, m v)] -> m (AttrSet v, PositionSet) buildResult scopes bindings = do @@ -335,13 +335,14 @@ evalBinds isRecursive binds = pure (coerce res, p) where + insert :: (AttrSet (m v), PositionSet) -> ([VarName], NSourcePos, m v) -> m (AttrSet (m v), PositionSet) insert (m, p) (path, pos, value) = attrSetAlter path pos m p value mkThunk = defer . withScopes scopes encapsulate f attrs = mkThunk $ pushScope attrs f - applyBindToAdt :: Scopes m v -> Binding (m v) -> m [([VarName], SourcePos, m v)] + applyBindToAdt :: Scopes m v -> Binding (m v) -> m [([VarName], NSourcePos, m v)] applyBindToAdt _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) = do (o', p') <- fromValue =<< finalValue @@ -363,7 +364,7 @@ evalBinds isRecursive binds = ) <$> processAttrSetKeys pathExpr where - processAttrSetKeys :: NAttrPath (m v) -> m ([VarName], SourcePos, m v) + processAttrSetKeys :: NAttrPath (m v) -> m ([VarName], NSourcePos, m v) processAttrSetKeys (h :| t) = maybe -- Empty attrset - return a stub. @@ -387,7 +388,7 @@ evalBinds isRecursive binds = where processScope :: VarName - -> ([VarName], SourcePos, m v) + -> ([VarName], NSourcePos, m v) processScope var = ( one var , pos diff --git a/src/Nix/Expr/Types.hs b/src/Nix/Expr/Types.hs index 8279faeb7..dd1810a80 100644 --- a/src/Nix/Expr/Types.hs +++ b/src/Nix/Expr/Types.hs @@ -18,7 +18,13 @@ -- [Brief on shallow & deep embedding.](https://web.archive.org/web/20201112031804/https://alessandrovermeulen.me/2013/07/13/the-difference-between-shallow-and-deep-embedding/) -- -- (additiona info for dev): Big use of TemplateHaskell in the module requires proper (top-down) organization of declarations. -module Nix.Expr.Types where +module Nix.Expr.Types + ( module Nix.Expr.Types + , SourcePos(..) + , unPos + , mkPos + ) +where import Nix.Prelude import qualified Codec.Serialise as Serialise @@ -40,10 +46,10 @@ import GHC.Generics import qualified Language.Haskell.TH.Syntax as TH import Lens.Family2 import Lens.Family2.TH -import Text.Megaparsec.Pos ( SourcePos(SourcePos) - , Pos +import Text.Megaparsec.Pos ( Pos , mkPos , unPos + , SourcePos(SourcePos) ) import Text.Show.Deriving ( deriveShow1, deriveShow2 ) import Text.Read.Deriving ( deriveRead1, deriveRead2 ) @@ -107,8 +113,8 @@ toSourcePos (NSourcePos f l c) = type AttrSet = HashMap VarName -- | Holds file positionng information for abstrations. --- A type synonym for @HashMap VarName SourcePos@. -type PositionSet = AttrSet SourcePos +-- A type synonym for @HashMap VarName NSourcePos@. +type PositionSet = AttrSet NSourcePos -- ** orphan instances @@ -116,43 +122,44 @@ type PositionSet = AttrSet SourcePos -- Upstreaming so far was not pursued. -instance Serialise Pos where - encode = Serialise.encode . unPos - decode = mkPos <$> Serialise.decode +instance Serialise NPos where + encode = Serialise.encode . unPos . coerce + decode = coerce . mkPos <$> Serialise.decode -instance Serialise SourcePos where - encode (SourcePos f l c) = +instance Serialise NSourcePos where + encode (NSourcePos f l c) = + coerce $ Serialise.encode f <> Serialise.encode l <> Serialise.encode c decode = - liftA3 SourcePos + liftA3 NSourcePos Serialise.decode Serialise.decode Serialise.decode -instance Hashable Pos where - hashWithSalt salt = hashWithSalt salt . unPos +instance Hashable NPos where + hashWithSalt salt = hashWithSalt salt . unPos . coerce -instance Hashable SourcePos where - hashWithSalt salt (SourcePos f l c) = +instance Hashable NSourcePos where + hashWithSalt salt (NSourcePos f l c) = salt `hashWithSalt` f `hashWithSalt` l `hashWithSalt` c -instance Binary Pos where - put = Binary.put . unPos - get = mkPos <$> Binary.get -instance Binary SourcePos +instance Binary NPos where + put = (Binary.put @Int) . unPos . coerce + get = coerce . mkPos <$> Binary.get +instance Binary NSourcePos -instance ToJSON Pos where - toJSON = toJSON . unPos -instance ToJSON SourcePos +instance ToJSON NPos where + toJSON = toJSON . unPos . coerce +instance ToJSON NSourcePos -instance FromJSON Pos where - parseJSON = fmap mkPos . parseJSON -instance FromJSON SourcePos +instance FromJSON NPos where + parseJSON = coerce . fmap mkPos . parseJSON +instance FromJSON NSourcePos -- * Components of Nix expressions @@ -447,23 +454,23 @@ instance Hashable1 NonEmpty -- | A single line of the bindings section of a let expression or of a set. data Binding r - = NamedVar !(NAttrPath r) !r !SourcePos + = NamedVar !(NAttrPath r) !r !NSourcePos -- ^ An explicit naming. -- - -- > NamedVar (StaticKey "x" :| [StaticKey "y"]) z SourcePos{} ~ x.y = z; - | Inherit !(Maybe r) ![VarName] !SourcePos + -- > NamedVar (StaticKey "x" :| [StaticKey "y"]) z NSourcePos{} ~ x.y = z; + | Inherit !(Maybe r) ![VarName] !NSourcePos -- ^ Inheriting an attribute (binding) into the attribute set from the other scope (attribute set). No denoted scope means to inherit from the closest outside scope. -- - -- +---------------------------------------------------------------+--------------------+-----------------------+ - -- | Hask | Nix | pseudocode | - -- +===============================================================+====================+=======================+ - -- | @Inherit Nothing [StaticKey "a"] SourcePos{}@ | @inherit a;@ | @a = outside.a;@ | - -- +---------------------------------------------------------------+--------------------+-----------------------+ - -- | @Inherit (pure x) [StaticKey "a"] SourcePos{}@ | @inherit (x) a;@ | @a = x.a;@ | - -- +---------------------------------------------------------------+--------------------+-----------------------+ - -- | @Inherit (pure x) [StaticKey "a", StaticKey "b"] SourcePos{}@ | @inherit (x) a b;@ | @a = x.a;@ | - -- | | | @b = x.b;@ | - -- +---------------------------------------------------------------+--------------------+-----------------------+ + -- +----------------------------------------------------------------+--------------------+-----------------------+ + -- | Hask | Nix | pseudocode | + -- +================================================================+====================+=======================+ + -- | @Inherit Nothing [StaticKey "a"] NSourcePos{}@ | @inherit a;@ | @a = outside.a;@ | + -- +----------------------------------------------------------------+--------------------+-----------------------+ + -- | @Inherit (pure x) [StaticKey "a"] NSourcePos{}@ | @inherit (x) a;@ | @a = x.a;@ | + -- +----------------------------------------------------------------+--------------------+-----------------------+ + -- | @Inherit (pure x) [StaticKey "a", StaticKey "b"] NSourcePos{}@ | @inherit (x) a b;@ | @a = x.a;@ | + -- | | | @b = x.b;@ | + -- +----------------------------------------------------------------+--------------------+-----------------------+ -- -- (2021-07-07 use details): -- Inherits the position of the first name through @unsafeGetAttrPos@. The position of the scope inherited from else - the position of the first member of the binds list. @@ -743,8 +750,8 @@ stripPositionInfo = transport phi erasePositions (NamedVar path r _pos) = NamedVar path r nullPos erasePositions (Inherit ms names _pos) = Inherit ms names nullPos -nullPos :: SourcePos -nullPos = on (SourcePos "") mkPos 1 1 +nullPos :: NSourcePos +nullPos = on (NSourcePos "") (coerce . mkPos) 1 1 -- * Dead code @@ -760,7 +767,7 @@ ekey :: forall ann g . NExprAnn ann g => NonEmpty VarName - -> SourcePos + -> NSourcePos -> Lens' (Fix g) (Maybe (Fix g)) ekey keys pos f e@(Fix x) | (NSet NonRecursive xs, ann) <- fromNExpr x = diff --git a/src/Nix/Expr/Types/Annotated.hs b/src/Nix/Expr/Types/Annotated.hs index 2eaf51d05..8b739c267 100644 --- a/src/Nix/Expr/Types/Annotated.hs +++ b/src/Nix/Expr/Types/Annotated.hs @@ -10,9 +10,6 @@ module Nix.Expr.Types.Annotated ( module Nix.Expr.Types.Annotated , module Data.Functor.Compose - , SourcePos(..) - , unPos - , mkPos ) where @@ -35,10 +32,6 @@ import Data.Ord.Deriving import GHC.Generics import Nix.Atoms import Nix.Expr.Types -import Text.Megaparsec ( unPos - , mkPos - ) -import Text.Megaparsec.Pos ( SourcePos(..) ) import Text.Read.Deriving import Text.Show.Deriving @@ -46,8 +39,8 @@ import Text.Show.Deriving -- | Demarcation of a chunk in a source file. data SrcSpan = SrcSpan - { spanBegin :: SourcePos - , spanEnd :: SourcePos + { getSpanBegin :: NSourcePos + , getSpanEnd :: NSourcePos } deriving (Ord, Eq, Generic, Typeable, Data, Show, NFData, Hashable) @@ -56,8 +49,8 @@ data SrcSpan = SrcSpan instance Semigroup SrcSpan where s1 <> s2 = SrcSpan - (on min spanBegin s1 s2) - (on max spanEnd s1 s2) + (on min getSpanBegin s1 s2) + (on max getSpanEnd s1 s2) instance Binary SrcSpan instance ToJSON SrcSpan @@ -183,8 +176,8 @@ annNAbs (AnnUnit s1 ps) e1@(Ann s2 _) = NAbsAnn (s1 <> s2) ps e1 annNStr :: AnnUnit SrcSpan (NString NExprLoc) -> NExprLoc annNStr (AnnUnit s1 s) = NStrAnn s1 s -deltaInfo :: SourcePos -> (Text, Int, Int) -deltaInfo (SourcePos fp l c) = (fromString fp, unPos l, unPos c) +deltaInfo :: NSourcePos -> (Text, Int, Int) +deltaInfo (NSourcePos fp l c) = (fromString $ coerce fp, unPos $ coerce l, unPos $ coerce c) annNNull :: NExprLoc annNNull = NConstantAnn nullSpan NNull diff --git a/src/Nix/Parser.hs b/src/Nix/Parser.hs index 64eac0ef6..a5959d278 100644 --- a/src/Nix/Parser.hs +++ b/src/Nix/Parser.hs @@ -108,10 +108,10 @@ annotateLocation1 :: Parser a -> Parser (AnnUnit SrcSpan a) annotateLocation1 p = do begin <- getSourcePos - res <- p + res <- p end <- get -- The state set before the last whitespace - pure $ AnnUnit (SrcSpan begin end) res + pure $ AnnUnit (SrcSpan (toNSourcePos begin) (toNSourcePos end)) res annotateLocation :: Parser (NExprF NExprLoc) -> Parser NExprLoc annotateLocation = (annUnitToAnn <$>) . annotateLocation1 @@ -401,7 +401,7 @@ nixBinders = (inherit <|> namedVar) `endBy` symbol ';' where label "inherited binding" $ liftA2 (Inherit x) (many identifier) - (pure p) + (pure (toNSourcePos p)) namedVar = do p <- getSourcePos @@ -409,7 +409,7 @@ nixBinders = (inherit <|> namedVar) `endBy` symbol ';' where liftA3 NamedVar (annotated <$> nixSelector) (exprAfterSymbol '=') - (pure p) + (pure (toNSourcePos p)) scope = label "inherit scope" nixParens nixSet :: Parser NExprLoc diff --git a/src/Nix/Reduce.hs b/src/Nix/Reduce.hs index a410a9b39..88950c84a 100644 --- a/src/Nix/Reduce.hs +++ b/src/Nix/Reduce.hs @@ -102,7 +102,7 @@ staticImport pann path = (\ err -> fail $ "Parse failed: " <> show err) (\ x -> do let - pos = join (SourcePos "Reduce.hs") $ mkPos 1 + pos = join (NSourcePos "Reduce.hs") $ (coerce . mkPos) 1 span = join SrcSpan pos cur = NamedVar diff --git a/src/Nix/Render.hs b/src/Nix/Render.hs index e6b6196e9..50fc17fdb 100644 --- a/src/Nix/Render.hs +++ b/src/Nix/Render.hs @@ -14,6 +14,9 @@ import qualified Data.Set as Set import Nix.Utils.Fix1 ( Fix1T , MonadFix1T ) +import Nix.Expr.Types ( NPos(..) + , NSourcePos(..) + ) import Nix.Expr.Types.Annotated import Prettyprinter import qualified System.Directory as S @@ -65,14 +68,14 @@ instance MonadFile IO where instance (MonadFix1T t m, MonadIO (Fix1T t m), MonadFail (Fix1T t m), MonadFile m) => MonadFile (Fix1T t m) -posAndMsg :: SourcePos -> Doc a -> ParseError s Void -posAndMsg (SourcePos _ lineNo _) msg = +posAndMsg :: NSourcePos -> Doc a -> ParseError s Void +posAndMsg (NSourcePos _ (coerce -> lineNo) _) msg = FancyError (unPos lineNo) (Set.fromList $ one (ErrorFail (show msg) :: ErrorFancy Void)) renderLocation :: MonadFile m => SrcSpan -> Doc a -> m (Doc a) -renderLocation (SrcSpan (SourcePos (coerce -> file) begLine begCol) (SourcePos (coerce -> file') endLine endCol)) msg +renderLocation (SrcSpan (NSourcePos file (coerce -> begLine) (coerce -> begCol)) (NSourcePos file' (coerce -> endLine) (coerce -> endCol))) msg | file == file' && file == "" && begLine == endLine = pure $ "In raw input string at position " <> pretty (unPos begCol) diff --git a/src/Nix/Render/Frame.hs b/src/Nix/Render/Frame.hs index c4d8e2dc6..abf3a7177 100644 --- a/src/Nix/Render/Frame.hs +++ b/src/Nix/Render/Frame.hs @@ -58,14 +58,14 @@ renderFrames xss@(x : xs) = renderPosition :: NixFrame -> [Doc ann] renderPosition = whenJust - (\ pos -> one ("While evaluating at " <> pretty (sourcePosPretty pos) <> colon)) + (\ pos -> one ("While evaluating at " <> pretty (sourcePosPretty $ toSourcePos pos) <> colon)) . framePos @v @m framePos :: forall v (m :: Type -> Type) . (Typeable m, Typeable v) => NixFrame - -> Maybe SourcePos + -> Maybe NSourcePos framePos (NixFrame _ f) = (\case EvaluatingExpr _ (Ann (SrcSpan beg _) _) -> pure beg diff --git a/tests/ParserTests.hs b/tests/ParserTests.hs index 7acdf52af..6094572c9 100644 --- a/tests/ParserTests.hs +++ b/tests/ParserTests.hs @@ -649,7 +649,7 @@ case_comments = case_simpleLoc = let - mkSPos = on (SourcePos "") mkPos + mkSPos = on (NSourcePos "") (coerce . mkPos) mkSpan = on SrcSpan (uncurry mkSPos) in assertParseTextLoc [text|let diff --git a/tests/PrettyParseTests.hs b/tests/PrettyParseTests.hs index 274cf26fd..4341718a5 100644 --- a/tests/PrettyParseTests.hs +++ b/tests/PrettyParseTests.hs @@ -22,7 +22,6 @@ import Nix.Pretty import Prettyprinter import Test.Tasty import Test.Tasty.Hedgehog -import Text.Megaparsec ( Pos ) import qualified Text.Show.Pretty as PS asciiString :: MonadGen m => m String @@ -35,16 +34,16 @@ asciiVarName :: Gen VarName asciiVarName = coerce <$> asciiText -- Might want to replace this instance with a constant value -genPos :: Gen Pos -genPos = mkPos <$> Gen.int (Range.linear 1 256) +genNPos :: Gen NPos +genNPos = fmap coerce $ mkPos <$> Gen.int (Range.linear 1 256) -genSourcePos :: Gen SourcePos -genSourcePos = +genNSourcePos :: Gen NSourcePos +genNSourcePos = join (liftA3 - SourcePos - asciiString + NSourcePos + (fmap coerce asciiString) ) - genPos + genNPos genKeyName :: Gen (NKeyName NExpr) genKeyName = @@ -59,11 +58,11 @@ genBinding = Gen.choice [ liftA3 NamedVar genAttrPath genExpr - genSourcePos + genNSourcePos , liftA3 Inherit (Gen.maybe genExpr) (Gen.list (Range.linear 0 5) asciiVarName) - genSourcePos + genNSourcePos ] genString :: Gen (NString NExpr)