More refactors

hnix.cabal

@@ -407,7 +407,7 @@ library
     , base >= 4.12 && < 5
     , base16-bytestring >= 0.1.1 && < 1.1
     , binary >= 0.8.5 && < 0.9
-    , bytestring >= 0.10.8 && < 0.11
+    , bytestring >= 0.10.8 && < 0.12
     , comonad >= 5.0.4 && < 5.1
     , containers >= 0.5.11.0 && < 0.7
     , data-fix >= 0.3.0 && < 0.4

src/Nix/Cited/Basic.hs

@@ -16,7 +16,6 @@ import           Prelude                 hiding ( force )
 import           Control.Comonad                ( Comonad )
 import           Control.Comonad.Env            ( ComonadEnv )
 import           Control.Monad.Catch     hiding ( catchJust )
-import           Data.Fix
 import           Nix.Cited
 import           Nix.Eval                      as Eval
 import           Nix.Exec
@@ -64,13 +63,12 @@ instance ( Has e Options
 
         -- Gather the current evaluation context at the time of thunk
         -- creation, and record it along with the thunk.
-        let go (fromException ->
-                    Just (EvaluatingExpr scope
-                              (Fix (Compose (Ann s e))))) =
-                let e' = Compose (Ann s (Nothing <$ e))
-                in [Provenance scope e']
-            go _ = mempty
-            ps = concatMap (go . frame) frames
+        let
+          go (fromException -> Just (EvaluatingExpr scope (AnnE s e))) =
+            let e' = Compose (Ann s (Nothing <$ e)) in
+            [Provenance scope e']
+          go _ = mempty
+          ps = concatMap (go . frame) frames
 
         Cited . NCited ps <$> thunk mv
       )

src/Nix/Eval.hs

@@ -15,7 +15,6 @@ module Nix.Eval where
 import           Control.Monad                  ( foldM )
 import           Control.Monad.Fix              ( MonadFix )
 import           Data.Semialign.Indexed         ( ialignWith )
-import           Data.Fix                       ( Fix(Fix) )
 import qualified Data.HashMap.Lazy             as M
 import           Data.List                      ( partition )
 import           Data.These                     ( These(..) )
@@ -496,7 +495,7 @@ buildArgument params arg =
 
 addSourcePositions
   :: (MonadReader e m, Has e SrcSpan) => Transform NExprLocF (m a)
-addSourcePositions f v@(Fix (Compose (Ann ann _))) =
+addSourcePositions f v@(AnnE ann _) =
   local (set hasLens ann) $ f v
 
 addStackFrames

src/Nix/Expr/Types.hs

@@ -108,6 +108,8 @@ data Params r
   --
   -- > Param "x"                                  ~  x
   | ParamSet !(ParamSet r) !Bool !(Maybe VarName)
+  --  2021-05-15: NOTE: Seems like we should flip the ParamSet, so partial application kicks in for Bool?
+  --  2021-05-15: NOTE: '...' variadic property probably needs a Bool synonym.
   -- ^ Explicit parameters (argument must be a set). Might specify a name to
   -- bind to the set in the function body. The bool indicates whether it is
   -- variadic or not.
@@ -432,6 +434,8 @@ data NExprF r
   -- > NBinary NPlus x y                           ~  x + y
   -- > NBinary NApp  f x                           ~  f x
   | NSelect !r !(NAttrPath r) !(Maybe r)
+  --  2021-05-15: NOTE: Default value should be first argument to leverage partial application.
+  -- Cascading change diff is not that big.
   -- ^ Dot-reference into an attribute set, optionally providing an
   -- alternative if the key doesn't exist.
   --

src/Nix/Expr/Types/Annotated.hs

@@ -47,17 +47,30 @@ import           Text.Megaparsec.Pos            ( SourcePos(..) )
 import           Text.Read.Deriving
 import           Text.Show.Deriving
 
--- | A location in a source file
+-- * data type @SrcSpan@ - a zone in a source file
+
+-- | Demarcation of a chunk in a source file.
 data SrcSpan = SrcSpan
     { spanBegin :: SourcePos
     , spanEnd   :: SourcePos
     }
     deriving (Ord, Eq, Generic, Typeable, Data, Show, NFData, Hashable)
 
+-- ** Instances
+
+instance Semigroup SrcSpan where
+  s1 <> s2 = SrcSpan ((min `on` spanBegin) s1 s2) ((max `on` spanEnd) s1 s2)
+
+instance Binary SrcSpan
+instance ToJSON SrcSpan
+instance FromJSON SrcSpan
+
 #ifdef MIN_VERSION_serialise
 instance Serialise SrcSpan
 #endif
 
+-- * data type @Ann@
+
 -- | A type constructor applied to a type along with an annotation
 --
 -- Intended to be used with 'Fix':
@@ -69,14 +82,30 @@ data Ann ann a = Ann
     deriving (Ord, Eq, Data, Generic, Generic1, Typeable, Functor, Foldable,
               Traversable, Read, Show, NFData, Hashable)
 
-instance Hashable ann => Hashable1 (Ann ann)
+type AnnF ann f = Compose (Ann ann) f
 
-#ifdef MIN_VERSION_serialise
-instance (Serialise ann, Serialise a) => Serialise (Ann ann a)
-#endif
+-- | Pattern: @Fix (Compose (Ann _ _))@.
+-- Fix composes units of (annotations & the annotated) into one object.
+-- Giving annotated expression.
+pattern AnnE
+  :: forall ann (g :: * -> *)
+  . ann
+  -> g (Fix (Compose (Ann ann) g))
+  -> Fix (Compose (Ann ann) g)
+pattern AnnE ann a = Fix (Compose (Ann ann a))
+{-# complete AnnE #-}
+
+annToAnnF :: Ann ann (f (Fix (AnnF ann f))) -> Fix (AnnF ann f)
+annToAnnF (Ann ann a) = AnnE ann a
+
+-- ** Instances
+
+instance Hashable ann => Hashable1 (Ann ann)
 
 instance NFData ann => NFData1 (Ann ann)
 
+instance (Binary ann, Binary a) => Binary (Ann ann a)
+
 $(deriveEq1   ''Ann)
 $(deriveEq2   ''Ann)
 $(deriveOrd1  ''Ann)
@@ -88,40 +117,32 @@ $(deriveShow2 ''Ann)
 $(deriveJSON1 defaultOptions ''Ann)
 $(deriveJSON2 defaultOptions ''Ann)
 
-instance Semigroup SrcSpan where
-  s1 <> s2 = SrcSpan ((min `on` spanBegin) s1 s2) ((max `on` spanEnd) s1 s2)
+#ifdef MIN_VERSION_serialise
+instance (Serialise ann, Serialise a) => Serialise (Ann ann a)
+#endif
 
-type AnnF ann f = Compose (Ann ann) f
+#ifdef MIN_VERSION_serialise
+instance Serialise r => Serialise (Compose (Ann SrcSpan) NExprF r) where
+  encode (Compose (Ann ann a)) = encode ann <> encode a
+  decode = (Compose .) . Ann <$> decode <*> decode
+#endif
 
-annToAnnF :: Ann ann (f (Fix (AnnF ann f))) -> Fix (AnnF ann f)
-annToAnnF (Ann ann a) = AnnE ann a
+-- ** @NExprLoc{,F}@ - annotated Nix expression
 
 type NExprLocF = AnnF SrcSpan NExprF
 
--- | A nix expression with source location at each subexpression.
+instance Binary r => Binary (NExprLocF r)
+
+-- | Annotated Nix expression (each subexpression direct to its source location).
 type NExprLoc = Fix NExprLocF
 
 #ifdef MIN_VERSION_serialise
 instance Serialise NExprLoc
 #endif
 
-instance Binary SrcSpan
-instance (Binary ann, Binary a) => Binary (Ann ann a)
-instance Binary r => Binary (NExprLocF r)
 instance Binary NExprLoc
 
-instance ToJSON SrcSpan
-instance FromJSON SrcSpan
-
-#ifdef MIN_VERSION_serialise
-instance Serialise r => Serialise (Compose (Ann SrcSpan) NExprF r) where
-  encode (Compose (Ann ann a)) = encode ann <> encode a
-  decode = (Compose .) . Ann <$> decode <*> decode
-#endif
-
-pattern AnnE :: forall ann (g :: * -> *). ann
-             -> g (Fix (Compose (Ann ann) g)) -> Fix (Compose (Ann ann) g)
-pattern AnnE ann a = Fix (Compose (Ann ann a))
+-- * Other
 
 stripAnnotation :: Functor f => Fix (AnnF ann f) -> Fix f
 stripAnnotation = unfoldFix (annotated . getCompose . unFix)
@@ -131,33 +152,32 @@ stripAnn = annotated . getCompose
 
 nUnary :: Ann SrcSpan NUnaryOp -> NExprLoc -> NExprLoc
 nUnary (Ann s1 u) e1@(AnnE s2 _) = AnnE (s1 <> s2) $ NUnary u e1
-nUnary _          _              = error "nUnary: unexpected"
 {-# inline nUnary #-}
 
 nBinary :: Ann SrcSpan NBinaryOp -> NExprLoc -> NExprLoc -> NExprLoc
 nBinary (Ann s1 b) e1@(AnnE s2 _) e2@(AnnE s3 _) =
   AnnE (s1 <> s2 <> s3) $ NBinary b e1 e2
-nBinary _ _ _ = error "nBinary: unexpected"
 
 nSelectLoc
   :: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> Maybe NExprLoc -> NExprLoc
-nSelectLoc e1@(AnnE s1 _) (Ann s2 ats) d = case d of
-  Nothing               -> AnnE (s1 <> s2) $ NSelect e1 ats Nothing
-  Just e2@(AnnE s3 _) -> AnnE (s1 <> s2 <> s3) $ NSelect e1 ats $ pure e2
-  _                     -> error "nSelectLoc: unexpected"
-nSelectLoc _ _ _ = error "nSelectLoc: unexpected"
+nSelectLoc e1@(AnnE s1 _) (Ann s2 ats) =
+  --  2021-05-16: NOTE: This could been rewritten into function application of @(s3, pure e2)@
+  -- if @SrcSpan@ was Monoid, which requires @SorcePos@ to be a Monoid, and upstream code prevents it.
+  -- Question upstream: https://github.com/mrkkrp/megaparsec/issues/450
+  maybe
+    (                    AnnE  s1s2        $ NSelect e1 ats   Nothing)
+    (\ e2@(AnnE s3 _) -> AnnE (s1s2 <> s3) $ NSelect e1 ats $ pure e2)
+ where
+  s1s2 = s1 <> s2
 
 nHasAttr :: NExprLoc -> Ann SrcSpan (NAttrPath NExprLoc) -> NExprLoc
 nHasAttr e1@(AnnE s1 _) (Ann s2 ats) = AnnE (s1 <> s2) $ NHasAttr e1 ats
-nHasAttr _              _            = error "nHasAttr: unexpected"
 
 nApp :: NExprLoc -> NExprLoc -> NExprLoc
 nApp e1@(AnnE s1 _) e2@(AnnE s2 _) = AnnE (s1 <> s2) $ NBinary NApp e1 e2
-nApp _              _              = error "nApp: unexpected"
 
 nAbs :: Ann SrcSpan (Params NExprLoc) -> NExprLoc -> NExprLoc
 nAbs (Ann s1 ps) e1@(AnnE s2 _) = AnnE (s1 <> s2) $ NAbs ps e1
-nAbs _           _              = error "nAbs: unexpected"
 
 nStr :: Ann SrcSpan (NString NExprLoc) -> NExprLoc
 nStr (Ann s1 s) = AnnE s1 $ NStr s
@@ -175,18 +195,15 @@ nullSpan = SrcSpan nullPos nullPos
 
 -- | Pattern systems for matching on NExprLocF constructions.
 
-pattern NSym_ :: SrcSpan -> VarName -> NExprLocF r
-pattern NSym_ ann x = Compose (Ann ann (NSym x))
-
-pattern NSynHole_ :: SrcSpan -> Text -> NExprLocF r
-pattern NSynHole_ ann x = Compose (Ann ann (NSynHole x))
-
 pattern NConstant_ :: SrcSpan -> NAtom -> NExprLocF r
 pattern NConstant_ ann x = Compose (Ann ann (NConstant x))
 
 pattern NStr_ :: SrcSpan -> NString r -> NExprLocF r
 pattern NStr_ ann x = Compose (Ann ann (NStr x))
 
+pattern NSym_ :: SrcSpan -> VarName -> NExprLocF r
+pattern NSym_ ann x = Compose (Ann ann (NSym x))
+
 pattern NList_ :: SrcSpan -> [r] -> NExprLocF r
 pattern NList_ ann x = Compose (Ann ann (NList x))
 
@@ -199,6 +216,12 @@ pattern NLiteralPath_ ann x = Compose (Ann ann (NLiteralPath x))
 pattern NEnvPath_ :: SrcSpan -> FilePath -> NExprLocF r
 pattern NEnvPath_ ann x = Compose (Ann ann (NEnvPath x))
 
+pattern NUnary_ :: SrcSpan -> NUnaryOp -> r -> NExprLocF r
+pattern NUnary_ ann op x = Compose (Ann ann (NUnary op x))
+
+pattern NBinary_ :: SrcSpan -> NBinaryOp -> r -> r -> NExprLocF r
+pattern NBinary_ ann op x y = Compose (Ann ann (NBinary op x y))
+
 pattern NSelect_ :: SrcSpan -> r -> NAttrPath r -> Maybe r -> NExprLocF r
 pattern NSelect_ ann x p v = Compose (Ann ann (NSelect x p v))
 
@@ -220,8 +243,6 @@ pattern NWith_ ann x y = Compose (Ann ann (NWith x y))
 pattern NAssert_ :: SrcSpan -> r -> r -> NExprLocF r
 pattern NAssert_ ann x y = Compose (Ann ann (NAssert x y))
 
-pattern NUnary_ :: SrcSpan -> NUnaryOp -> r -> NExprLocF r
-pattern NUnary_ ann op x = Compose (Ann ann (NUnary op x))
-
-pattern NBinary_ :: SrcSpan -> NBinaryOp -> r -> r -> NExprLocF r
-pattern NBinary_ ann op x y = Compose (Ann ann (NBinary op x y))
+pattern NSynHole_ :: SrcSpan -> Text -> NExprLocF r
+pattern NSynHole_ ann x = Compose (Ann ann (NSynHole x))
+{-# complete NConstant_, NStr_, NSym_, NList_, NSet_, NLiteralPath_, NEnvPath_, NUnary_, NBinary_, NSelect_, NHasAttr_, NAbs_, NLet_, NIf_, NWith_, NAssert_, NSynHole_ #-}