Report lexical collisions with source locations

Built-in patterns remain authoritative syntax seeds: their first source declaration records provenance without replacing the seeded marker.

2 files changed, 147 insertions, 80 deletions

diff --git a/source/Syntax/Adapt.hs b/source/Syntax/Adapt.hs
index 3d75a18..069f896 100644
--- a/source/Syntax/Adapt.hs
+++ b/source/Syntax/Adapt.hs
@@ -36,8 +36,18 @@ scanChunk ltoks =
             scanDatatypeChunk pos toks
         _ -> []
 
-adaptChunks :: [[Located Token]] -> Lexicon -> Lexicon
-adaptChunks = extendLexicon . concatMap scanChunk
+buildWorkspaceLexicon
+    :: [[Located Token]]
+    -> Either LexiconCollision Lexicon
+buildWorkspaceLexicon chunks =
+    buildingLexicon
+        <$> foldlM extendLexicon initialState
+            [ (startPos firstToken, item)
+            | chunk@(firstToken : _) <- chunks
+            , item <- scanChunk chunk
+            ]
+  where
+    initialState = LexiconBuildState builtins mempty
 
 data ScannedLexicalItem
     = ScanAdj LexicalPhrase Marker
@@ -51,6 +61,32 @@ data ScannedLexicalItem
     | ScanStructOp Text -- we an use the command text as export name.
     deriving (Show, Eq)
 
+data LexiconCollision = LexiconCollision
+    { lexiconCollisionPattern :: !Pattern
+    , lexiconCollisionFirstDeclaration :: !Location
+    , lexiconCollisionSecondDeclaration :: !Location
+    } deriving (Eq)
+
+instance Show LexiconCollision where
+    show LexiconCollision{..} =
+        let (firstLocation, secondLocation) =
+                prettyLocationPair
+                    lexiconCollisionFirstDeclaration
+                    lexiconCollisionSecondDeclaration
+        in
+            "lexical pattern " <> show lexiconCollisionPattern
+                <> " is declared more than once:\n"
+                <> "  first declaration at "
+                <> firstLocation
+                <> "\n"
+                <> "  colliding declaration at "
+                <> secondLocation
+
+data LexiconBuildState = LexiconBuildState
+    { buildingLexicon :: !Lexicon
+    , sourceDeclarations :: !(Map Pattern Location)
+    }
+
 skipUntilNextLexicalEnv :: RE Token [Token]
 skipUntilNextLexicalEnv = many (RE.psym otherToken)
     where
@@ -546,86 +582,111 @@ insertMapR k x xs = xs `Map.union` Map.singleton k x -- @union@ is left-biased.
 insertR :: Ord k => k -> a -> Map k a -> Map k a
 insertR k x xs = xs `Map.union` Map.singleton k x -- @union@ is left-biased.
 
--- | Takes the scanned lexical phrases and inserts them in the correct
--- places in a lexicon.
-extendLexicon :: [ScannedLexicalItem] -> Lexicon -> Lexicon
-extendLexicon [] lexicon = lexicon
+extendLexicon
+    :: LexiconBuildState
+    -> (Location, ScannedLexicalItem)
+    -> Either LexiconCollision LexiconBuildState
+extendLexicon state (location, scan) =
+    let currentLexicon = buildingLexicon state
+        (pat, extendedLexicon) =
+            insertScannedItem scan currentLexicon
+    in case Map.lookup pat (sourceDeclarations state) of
+        Just firstLocation ->
+            Left
+                (LexiconCollision
+                    pat
+                    firstLocation
+                    location)
+        Nothing ->
+            Right
+                (LexiconBuildState
+                    { buildingLexicon =
+                        if pat `Set.member` lexiconAllPatterns currentLexicon
+                            then currentLexicon
+                            else extendedLexicon
+                    , sourceDeclarations =
+                        Map.insert
+                            pat
+                            location
+                            (sourceDeclarations state)
+                    })
+
 -- Note that we only consider 'sg' in the 'Ord' instance of SgPl, so that
 -- known irregular plurals are preserved.
-extendLexicon (scan : scans) lexicon@Lexicon{..} = case scan of
-    ScanAdj item m ->
-        let li = mkLexicalItem item m
-            pat = lexicalItemPattern li
-        in if isAdjR item
-            then
-                let (items', patterns') = insertItem pat li lexiconAdjRs lexiconAllPatterns
-                in extendLexicon scans lexicon{lexiconAdjRs = items', lexiconAllPatterns = patterns'}
-            else
-                let (items', patterns') = insertItem pat li lexiconAdjLs lexiconAllPatterns
-                in extendLexicon scans lexicon{lexiconAdjLs = items', lexiconAllPatterns = patterns'}
-    ScanFun item m ->
-        let li = mkLexicalItemSgPl (guessNounPlural item) m
-            pat = baseSgPlPattern li
-            (items', patterns') = insertItem pat li lexiconFuns lexiconAllPatterns
-        in extendLexicon scans lexicon{lexiconFuns = items', lexiconAllPatterns = patterns'}
-    ScanVerb item m ->
-        let li = mkLexicalItemSgPl (guessVerbPlural item) m
-            pat = baseSgPlPattern li
-            (items', patterns') = insertItem pat li lexiconVerbs lexiconAllPatterns
-        in extendLexicon scans lexicon{lexiconVerbs = items', lexiconAllPatterns = patterns'}
-    ScanNoun item m ->
-        let li = mkLexicalItemSgPl (guessNounPlural item) m
-            pat = baseSgPlPattern li
-            (items', patterns') = insertItem pat li lexiconNouns lexiconAllPatterns
-        in extendLexicon scans lexicon{lexiconNouns = items', lexiconAllPatterns = patterns'}
-    ScanStructNoun item m ->
-        let li = mkLexicalItemSgPl (guessNounPlural item) m
-            pat = baseSgPlPattern li
-            (items', patterns') = insertItem pat li lexiconStructNouns lexiconAllPatterns
-        in extendLexicon scans lexicon{lexiconStructNouns = items', lexiconAllPatterns = patterns'}
-    ScanRelationSymbol item m ->
-        let sym = RelationSymbol item m
-            pat = relationSymbolPattern sym
-            (items', patterns') = insertItem pat sym lexiconRelationSymbols lexiconAllPatterns
-        in extendLexicon scans lexicon{lexiconRelationSymbols = items', lexiconAllPatterns = patterns'}
-    ScanFunctionSymbol pat m ->
-        if mixfixPatternExists pat lexiconAllPatterns
-            then warnExists pat (extendLexicon scans lexicon)
-            else extendLexicon scans lexicon
-                { lexiconMixfixTable = Seq.adjust (Map.insert pat (MixfixItem pat m NonAssoc)) 9 lexiconMixfixTable
-                , lexiconAllPatterns = Set.insert pat lexiconAllPatterns
-                }
-    ScanStructOp op ->
-        let sym = StructSymbol op
-            pat = structSymbolPattern sym
-            (items', patterns') = insertStruct pat sym lexiconStructFun lexiconAllPatterns
-        in extendLexicon scans lexicon{lexiconStructFun = items', lexiconAllPatterns = patterns'}
-    ScanPrefixPredicate tok m ->
-        let pat = prefixPattern tok
-            (items', patterns') = insertPrefix pat (tok, m) lexiconPrefixPredicates lexiconAllPatterns
-        in extendLexicon scans lexicon{lexiconPrefixPredicates = items', lexiconAllPatterns = patterns'}
-
-mixfixPatternExists :: Pattern -> Set Pattern -> Bool
-mixfixPatternExists pat patterns = Set.member pat patterns
-
-insertItem :: Pattern -> a -> [a] -> Set Pattern -> ([a], Set Pattern)
-insertItem pat item items patterns =
-    if Set.member pat patterns then warnExists pat (items, patterns) else (item : items, Set.insert pat patterns)
-
-insertStruct :: Pattern -> StructSymbol -> [StructSymbol] -> Set Pattern -> ([StructSymbol], Set Pattern)
-insertStruct pat item items patterns =
-    if Set.member pat patterns then warnExists pat (items, patterns) else (item : items, Set.insert pat patterns)
-
-insertPrefix :: Pattern -> (PrefixPredicate, Marker) -> [(PrefixPredicate, Marker)] -> Set Pattern -> ([(PrefixPredicate, Marker)], Set Pattern)
-insertPrefix pat item items patterns =
-    if Set.member pat patterns then warnExists pat (items, patterns) else (item : items, Set.insert pat patterns)
+insertScannedItem
+    :: ScannedLexicalItem
+    -> Lexicon
+    -> (Pattern, Lexicon)
+insertScannedItem scan lexicon@Lexicon{..} =
+    case scan of
+        ScanAdj item m ->
+            let li = mkLexicalItem item m
+                pat = lexicalItemPattern li
+                extended
+                    | isAdjR item =
+                        lexicon{lexiconAdjRs = li : lexiconAdjRs}
+                    | otherwise =
+                        lexicon{lexiconAdjLs = li : lexiconAdjLs}
+            in insertPattern pat extended
+        ScanFun item m ->
+            let li = mkLexicalItemSgPl (guessNounPlural item) m
+                pat = baseSgPlPattern li
+            in insertPattern pat
+                lexicon{lexiconFuns = li : lexiconFuns}
+        ScanVerb item m ->
+            let li = mkLexicalItemSgPl (guessVerbPlural item) m
+                pat = baseSgPlPattern li
+            in insertPattern pat
+                lexicon{lexiconVerbs = li : lexiconVerbs}
+        ScanNoun item m ->
+            let li = mkLexicalItemSgPl (guessNounPlural item) m
+                pat = baseSgPlPattern li
+            in insertPattern pat
+                lexicon{lexiconNouns = li : lexiconNouns}
+        ScanStructNoun item m ->
+            let li = mkLexicalItemSgPl (guessNounPlural item) m
+                pat = baseSgPlPattern li
+            in insertPattern pat
+                lexicon{lexiconStructNouns = li : lexiconStructNouns}
+        ScanRelationSymbol item m ->
+            let sym = RelationSymbol item m
+                pat = relationSymbolPattern sym
+            in insertPattern pat
+                lexicon
+                    { lexiconRelationSymbols =
+                        sym : lexiconRelationSymbols
+                    }
+        ScanFunctionSymbol pat m ->
+            insertPattern pat
+                lexicon
+                    { lexiconMixfixTable =
+                        Seq.adjust
+                            (Map.insert
+                                pat
+                                (MixfixItem pat m NonAssoc))
+                            9
+                            lexiconMixfixTable
+                    }
+        ScanStructOp op ->
+            let sym = StructSymbol op
+                pat = structSymbolPattern sym
+            in insertPattern pat
+                lexicon{lexiconStructFun = sym : lexiconStructFun}
+        ScanPrefixPredicate tok m ->
+            let pat = prefixPredicatePattern tok
+            in insertPattern pat
+                lexicon
+                    { lexiconPrefixPredicates =
+                        (tok, m) : lexiconPrefixPredicates
+                    }
+  where
+    insertPattern pat extended =
+        ( pat
+        , extended
+            { lexiconAllPatterns =
+                Set.insert pat lexiconAllPatterns
+            }
+        )
 
 baseSgPlPattern :: LexicalItemSgPl -> Pattern
 baseSgPlPattern = sg . lexicalItemSgPlPattern
-
-prefixPattern :: PrefixPredicate -> Pattern
-prefixPattern (PrefixPredicate cmd _arity) =
-    TokenCons (Command cmd) End
-
-warnExists :: Pattern -> a -> a
-warnExists pat = trace ("% WARNING: Lexical pattern already exists: " <> show pat)
diff --git a/source/Syntax/Lexicon.hs b/source/Syntax/Lexicon.hs
index 1b77242..027722e 100644
--- a/source/Syntax/Lexicon.hs
+++ b/source/Syntax/Lexicon.hs
@@ -83,8 +83,14 @@ lexiconPatterns Lexicon{..} =
         , Set.fromList (sg . lexicalItemSgPlPattern <$> lexiconFuns)
         , Set.fromList (relationSymbolPattern <$> lexiconRelationSymbols)
         , Set.fromList (structSymbolPattern <$> lexiconStructFun)
+        , Set.fromList
+            (prefixPredicatePattern . fst <$> lexiconPrefixPredicates)
         ]
 
+prefixPredicatePattern :: PrefixPredicate -> Pattern
+prefixPredicatePattern (PrefixPredicate command _arity) =
+    TokenCons (Command command) End
+
 builtinMixfixTable :: Seq (Map Pattern MixfixItem)
 builtinMixfixTable = Seq.fromList $ Map.fromList . fmap toEntry <$> builtinMixfixLevels
     where