Implement qualification.

Big change. Implements qualification, which separates the qualification
concerns from the ConsistencyCheck phase.

I'm getting close to implementing a backend.

1 files changed, 30 insertions, 18 deletions

diff --git a/src/Language/Fiddle/Internal/Scopes.hs b/src/Language/Fiddle/Internal/Scopes.hs
index 70cadee..c232328 100644
--- a/src/Language/Fiddle/Internal/Scopes.hs
+++ b/src/Language/Fiddle/Internal/Scopes.hs
@@ -2,20 +2,22 @@
 
 module Language.Fiddle.Internal.Scopes where
 
+import Data.Foldable
 import Data.Aeson
 import Data.Aeson.Key
 import Data.List (inits)
 import Data.List.NonEmpty (NonEmpty (..), prependList)
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, maybeToList)
+import Control.Arrow (Arrow(first))
 
 -- | 'Scope' represents a hierarchical structure for storing key-value pairs.
 --   It can contain nested sub-scopes, which are stored in 'subScopes',
 --   and the values for a specific scope are stored in 'scopeValues'.
 data Scope k v = Scope
   { subScopes :: Map k (Scope k v), -- Nested sub-scopes
-    scopeValues :: Map k v -- Values stored in the current scope
+    scopeValues :: Map k [v] -- Values stored in the current scope
   }
   deriving (Eq, Ord, Show, Read, Functor, Foldable)
 
@@ -29,24 +31,24 @@ data ScopePath k = ScopePath
   deriving (Eq, Ord, Show, Read)
 
 -- | Qualify a name with the current scope.
-qualifyPath :: ScopePath k -> k -> [k]
-qualifyPath ScopePath {currentScope = scope} k = scope ++ [k]
+qualifyPath :: ScopePath k -> NonEmpty k -> NonEmpty k
+qualifyPath ScopePath {currentScope = scope} = prependList scope
 
 -- | Push a new scope onto the current scope.
-pushScope :: k -> ScopePath k -> ScopePath k
+pushScope :: NonEmpty k -> ScopePath k -> ScopePath k
 pushScope v s@ScopePath {currentScope = scope} =
-  s {currentScope = scope ++ [v]}
+  s {currentScope = scope ++ toList v}
 
 -- | Adds a path to the "using" paths.
-addUsingPath :: [k] -> ScopePath k -> ScopePath k
+addUsingPath :: NonEmpty k -> ScopePath k -> ScopePath k
 addUsingPath path s@ScopePath {usingPaths = paths} =
-  s {usingPaths = path : paths}
+  s {usingPaths = toList path : paths}
 
 -- | The 'Semigroup' instance for 'Scope' allows combining two scopes,
 --   where sub-scopes and values are merged together.
 instance (Ord k) => Semigroup (Scope k t) where
   (Scope ss1 sv1) <> (Scope ss2 sv2) =
-    Scope (Map.unionWith (<>) ss1 ss2) (Map.union sv1 sv2)
+    Scope (Map.unionWith (<>) ss1 ss2) (Map.unionWith (<>) sv1 sv2)
 
 -- | The 'Monoid' instance for 'Scope' provides an empty scope with
 --   no sub-scopes or values.
@@ -71,9 +73,10 @@ instance Monoid (ScopePath k) where
 --   This function effectively performs an "insert-or-update" operation, allowing
 --   you to upsert values into nested scopes while tracking any existing value
 --   that was replaced.
-upsertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> (Maybe t, Scope k t)
+upsertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> ([t], Scope k t)
 upsertScope (s :| []) v (Scope ss sv) =
-  Scope ss <$> Map.insertLookupWithKey (\_ n _ -> n) s v sv
+  first (fromMaybe []) $
+    Scope ss <$> Map.insertLookupWithKey (const (<>)) s [v] sv
 upsertScope (s :| (a : as)) v (Scope ss sv) =
   let subscope = fromMaybe mempty (Map.lookup s ss)
       (replaced, subscope') = upsertScope (a :| as) v subscope
@@ -82,15 +85,18 @@ upsertScope (s :| (a : as)) v (Scope ss sv) =
 insertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> Scope k t
 insertScope p s = snd . upsertScope p s
 
+singleton :: (Ord k) => NonEmpty k -> t -> Scope k t
+singleton ks t = insertScope ks t mempty
+
 -- insertScope :: (Ord k) => NonEmpty k -> t -> Scope k t -> Scope k t
 -- insertScope a b = snd . upsertScope a b
 
 -- | 'lookupScope' performs a lookup of a value in the scope using a key path
 --   ('NonEmpty k'). It traverses through sub-scopes as defined by the path.
-lookupScope :: (Ord k) => NonEmpty k -> Scope k t -> Maybe t
-lookupScope (s :| []) (Scope _ sv) = Map.lookup s sv
+lookupScope :: (Ord k) => NonEmpty k -> Scope k t -> [t]
+lookupScope (s :| []) (Scope _ sv) = fromMaybe [] $ Map.lookup s sv
 lookupScope (s :| (a : as)) (Scope ss _) = do
-  subscope <- Map.lookup s ss
+  subscope <- maybeToList $ Map.lookup s ss
   lookupScope (a :| as) subscope
 
 -- | 'lookupScopeWithPath' searches for a key in the scope by trying all possible
@@ -122,10 +128,16 @@ lookupScopeWithPath ::
   [(NonEmpty k, t)]
 lookupScopeWithPath (ScopePath current others) key scope =
   let allPaths = reverse (inits current) ++ others
-   in flip concatMap allPaths $ \prefix -> do
-        case lookupScope (prependList prefix key) scope of
-          Just s -> [(prependList prefix key, s)]
-          Nothing -> []
+   in do
+        prefix <- allPaths
+        let qualifiedKey = prependList prefix key
+        value <- lookupScope qualifiedKey scope
+        return (qualifiedKey, value)
+
+-- flip concatMap allPaths $ \prefix -> do
+--      case lookupScope (prependList prefix key) scope of
+--        Just s -> [(prependList prefix key, s)]
+--        Nothing -> []
 
 instance (ToJSONKey k, ToJSON v, Ord k) => ToJSON (Scope k v) where
   toJSON scope =