{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedRecordDot #-}

module Nanopass.Internal.Extend
  ( extendLang
  , partitionNontermsEdits
  , EditingNonterms
  , addNonterms
  , modNonterms
  , delNonterms
  , extendProductions
  , partitionProductionsEdits
  ) where

import Prelude hiding (mod)
import Nanopass.Internal.Representation

import Control.Monad (forM_,when)
import Data.Functor ((<&>))
import Data.List (nub, (\\))
import Data.Map (Map)
import Data.Set (Set)
import Nanopass.Internal.Error (Error(..))
import Nanopass.Internal.Validate (validateParams,validateNonterm,validateProd)

import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Language.Haskell.TH as TH

extendLang :: Language 'Valid UpDotName -> LangMod -> Either Error (Language 'Valid UpName)
extendLang :: Language 'Valid UpDotName
-> LangMod -> Either Error (Language 'Valid UpName)
extendLang Language 'Valid UpDotName
orig LangMod
mod = do
  let ([Nonterm 'Unvalidated]
additions, [(UpName, [ProductionsEdit])]
mods, [UpName]
deletions) = [NontermsEdit]
-> ([Nonterm 'Unvalidated], [(UpName, [ProductionsEdit])],
    [UpName])
partitionNontermsEdits LangMod
mod.nontermsEdit
  [(UpName, [ProductionsEdit])]
-> ((UpName, [ProductionsEdit]) -> Either Error ())
-> Either Error ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(UpName, [ProductionsEdit])]
mods (((UpName, [ProductionsEdit]) -> Either Error ())
 -> Either Error ())
-> ((UpName, [ProductionsEdit]) -> Either Error ())
-> Either Error ()
forall a b. (a -> b) -> a -> b
$ \(UpName
n, [ProductionsEdit]
_) -> case (UpName
n UpName -> [UpName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((.nontermName.name) (Nonterm 'Unvalidated -> UpName)
-> [Nonterm 'Unvalidated] -> [UpName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Nonterm 'Unvalidated]
additions), UpName
n UpName -> [UpName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UpName]
deletions) of
    (Bool
_, Bool
True) -> Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ()) -> Error -> Either Error ()
forall a b. (a -> b) -> a -> b
$ UpName -> Error
IllegalNontermModificationAlsoDeleted UpName
n
    (Bool
True, Bool
_) -> Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ()) -> Error -> Either Error ()
forall a b. (a -> b) -> a -> b
$ UpName -> Error
IllegalNontermModificationAlsoAdded UpName
n
    (Bool, Bool)
_ -> () -> Either Error ()
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  [Nonterm 'Unvalidated]
-> (Nonterm 'Unvalidated -> Either Error ()) -> Either Error ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Nonterm 'Unvalidated]
additions ((Nonterm 'Unvalidated -> Either Error ()) -> Either Error ())
-> (Nonterm 'Unvalidated -> Either Error ()) -> Either Error ()
forall a b. (a -> b) -> a -> b
$ \Nonterm 'Unvalidated
add -> case Nonterm 'Unvalidated
add.nontermName.name UpName -> [UpName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UpName]
deletions of
    Bool
True -> Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ()) -> Error -> Either Error ()
forall a b. (a -> b) -> a -> b
$ UpName -> Error
IllegalNontermAddedAlsoDeleted Nonterm 'Unvalidated
add.nontermName.name
    Bool
_ -> () -> Either Error ()
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  do
    let modNames :: [UpName]
modNames = (UpName, [ProductionsEdit]) -> UpName
forall a b. (a, b) -> a
fst ((UpName, [ProductionsEdit]) -> UpName)
-> [(UpName, [ProductionsEdit])] -> [UpName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UpName, [ProductionsEdit])]
mods
        duplicates :: [UpName]
duplicates = [UpName]
modNames [UpName] -> [UpName] -> [UpName]
forall a. Eq a => [a] -> [a] -> [a]
\\ [UpName] -> [UpName]
forall a. Eq a => [a] -> [a]
nub [UpName]
modNames
    Bool -> Either Error () -> Either Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [UpName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UpName]
duplicates) (Either Error () -> Either Error ())
-> Either Error () -> Either Error ()
forall a b. (a -> b) -> a -> b
$
      Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ()) -> Error -> Either Error ()
forall a b. (a -> b) -> a -> b
$ [UpName] -> Error
DuplicateNontermMods [UpName]
modNames
  let modifications :: Map UpName [ProductionsEdit]
modifications = [(UpName, [ProductionsEdit])] -> Map UpName [ProductionsEdit]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UpName, [ProductionsEdit])]
mods
  [Name 'Valid LowName]
params <- [Name 'Unvalidated LowName] -> Either Error [Name 'Valid LowName]
validateParams LangMod
mod.newParams
  let tvs :: Map LowName (Name 'Valid LowName)
tvs = [(LowName, Name 'Valid LowName)]
-> Map LowName (Name 'Valid LowName)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(LowName, Name 'Valid LowName)]
 -> Map LowName (Name 'Valid LowName))
-> [(LowName, Name 'Valid LowName)]
-> Map LowName (Name 'Valid LowName)
forall a b. (a -> b) -> a -> b
$ [Name 'Valid LowName]
params [Name 'Valid LowName]
-> (Name 'Valid LowName -> (LowName, Name 'Valid LowName))
-> [(LowName, Name 'Valid LowName)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Name 'Valid LowName
n -> (Name 'Valid LowName
n.name, Name 'Valid LowName
n)
      nts :: Set UpName
nts = ([UpName] -> Set UpName
forall a. Ord a => [a] -> Set a
Set.fromList (EditingNonterms -> [UpName]
forall k a. Map k a -> [k]
Map.keys Language 'Valid UpDotName
orig.langInfo.nonterms)
              Set UpName -> Set UpName -> Set UpName
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` [UpName] -> Set UpName
forall a. Ord a => [a] -> Set a
Set.fromList [UpName]
deletions)
            Set UpName -> Set UpName -> Set UpName
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [UpName] -> Set UpName
forall a. Ord a => [a] -> Set a
Set.fromList ((.nontermName.name) (Nonterm 'Unvalidated -> UpName)
-> [Nonterm 'Unvalidated] -> [UpName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Nonterm 'Unvalidated]
additions)
  EditingNonterms
newNonterms <-  EditingNonterms -> Either Error EditingNonterms
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Language 'Valid UpDotName
orig.langInfo.nonterms)
              Either Error EditingNonterms
-> (EditingNonterms -> Either Error EditingNonterms)
-> Either Error EditingNonterms
forall a b.
Either Error a -> (a -> Either Error b) -> Either Error b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [UpName] -> EditingNonterms -> Either Error EditingNonterms
delNonterms [UpName]
deletions
              Either Error EditingNonterms
-> (EditingNonterms -> Either Error EditingNonterms)
-> Either Error EditingNonterms
forall a b.
Either Error a -> (a -> Either Error b) -> Either Error b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Set UpName
-> Map LowName (Name 'Valid LowName)
-> Map UpName [ProductionsEdit]
-> EditingNonterms
-> Either Error EditingNonterms
modNonterms Set UpName
nts Map LowName (Name 'Valid LowName)
tvs Map UpName [ProductionsEdit]
modifications
              Either Error EditingNonterms
-> (EditingNonterms -> Either Error EditingNonterms)
-> Either Error EditingNonterms
forall a b.
Either Error a -> (a -> Either Error b) -> Either Error b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Set UpName
-> Map LowName (Name 'Valid LowName)
-> [Nonterm 'Unvalidated]
-> EditingNonterms
-> Either Error EditingNonterms
addNonterms Set UpName
nts Map LowName (Name 'Valid LowName)
tvs [Nonterm 'Unvalidated]
additions
  Language 'Valid UpName -> Either Error (Language 'Valid UpName)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Language
    { $sel:langName:Language :: Name 'Valid UpName
langName = UpName -> Name -> Name 'Valid UpName
forall n. n -> Name -> Name 'Valid n
ValidName LangMod
mod.newLang (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ UpName -> String
fromUpName LangMod
mod.newLang)
    , $sel:langInfo:Language :: LanguageInfo 'Valid
langInfo = LanguageInfo
      { $sel:langParams:LanguageInfo :: [Name 'Valid LowName]
langParams = [Name 'Valid LowName]
params
      , $sel:nonterms:LanguageInfo :: EditingNonterms
nonterms = EditingNonterms
newNonterms
      , $sel:originalProgram:LanguageInfo :: Maybe String
originalProgram = LangMod
mod.originalModProgram
      , $sel:baseDefdLang:LanguageInfo :: Maybe (Language 'Valid UpDotName)
baseDefdLang = Language 'Valid UpDotName -> Maybe (Language 'Valid UpDotName)
forall a. a -> Maybe a
Just Language 'Valid UpDotName
orig
      }
    }

----------------------------------
------ Nonterminals Editing ------
----------------------------------

partitionNontermsEdits :: [NontermsEdit] -> ([Nonterm 'Unvalidated], [(UpName, [ProductionsEdit])], [UpName])
partitionNontermsEdits :: [NontermsEdit]
-> ([Nonterm 'Unvalidated], [(UpName, [ProductionsEdit])],
    [UpName])
partitionNontermsEdits = ([Nonterm 'Unvalidated], [(UpName, [ProductionsEdit])], [UpName])
-> [NontermsEdit]
-> ([Nonterm 'Unvalidated], [(UpName, [ProductionsEdit])],
    [UpName])
loop ([], [], [])
  where
  loop :: ([Nonterm 'Unvalidated], [(UpName, [ProductionsEdit])], [UpName])
-> [NontermsEdit]
-> ([Nonterm 'Unvalidated], [(UpName, [ProductionsEdit])],
    [UpName])
loop ([Nonterm 'Unvalidated]
as, [(UpName, [ProductionsEdit])]
ms, [UpName]
ds) [] = ([Nonterm 'Unvalidated] -> [Nonterm 'Unvalidated]
forall a. [a] -> [a]
reverse [Nonterm 'Unvalidated]
as, [(UpName, [ProductionsEdit])] -> [(UpName, [ProductionsEdit])]
forall a. [a] -> [a]
reverse [(UpName, [ProductionsEdit])]
ms, [UpName] -> [UpName]
forall a. [a] -> [a]
reverse [UpName]
ds)
  loop ([Nonterm 'Unvalidated]
as, [(UpName, [ProductionsEdit])]
ms, [UpName]
ds) (NontermsEdit
x:[NontermsEdit]
xs) = case NontermsEdit
x of
    AddNonterm Nonterm 'Unvalidated
a -> ([Nonterm 'Unvalidated], [(UpName, [ProductionsEdit])], [UpName])
-> [NontermsEdit]
-> ([Nonterm 'Unvalidated], [(UpName, [ProductionsEdit])],
    [UpName])
loop (Nonterm 'Unvalidated
aNonterm 'Unvalidated
-> [Nonterm 'Unvalidated] -> [Nonterm 'Unvalidated]
forall a. a -> [a] -> [a]
:[Nonterm 'Unvalidated]
as, [(UpName, [ProductionsEdit])]
ms, [UpName]
ds) [NontermsEdit]
xs
    ModNonterm UpName
n [ProductionsEdit]
m -> ([Nonterm 'Unvalidated], [(UpName, [ProductionsEdit])], [UpName])
-> [NontermsEdit]
-> ([Nonterm 'Unvalidated], [(UpName, [ProductionsEdit])],
    [UpName])
loop ([Nonterm 'Unvalidated]
as, (UpName
n, [ProductionsEdit]
m)(UpName, [ProductionsEdit])
-> [(UpName, [ProductionsEdit])] -> [(UpName, [ProductionsEdit])]
forall a. a -> [a] -> [a]
:[(UpName, [ProductionsEdit])]
ms, [UpName]
ds) [NontermsEdit]
xs
    DelNonterm UpName
d -> ([Nonterm 'Unvalidated], [(UpName, [ProductionsEdit])], [UpName])
-> [NontermsEdit]
-> ([Nonterm 'Unvalidated], [(UpName, [ProductionsEdit])],
    [UpName])
loop ([Nonterm 'Unvalidated]
as, [(UpName, [ProductionsEdit])]
ms, UpName
dUpName -> [UpName] -> [UpName]
forall a. a -> [a] -> [a]
:[UpName]
ds) [NontermsEdit]
xs

type EditingNonterms = Map UpName (Nonterm 'Valid)

addNonterms :: Set UpName -- ^ known non-terminals for the new language
            -> Map LowName (Name 'Valid LowName) -- ^ known type variables for the new language
            -> [Nonterm 'Unvalidated] -- ^ new non-terminals to add
            -> EditingNonterms -- ^ old language's non-terminals
            -> Either Error EditingNonterms
addNonterms :: Set UpName
-> Map LowName (Name 'Valid LowName)
-> [Nonterm 'Unvalidated]
-> EditingNonterms
-> Either Error EditingNonterms
addNonterms Set UpName
nts Map LowName (Name 'Valid LowName)
tvs [Nonterm 'Unvalidated]
adds EditingNonterms
orig = EditingNonterms
-> [Nonterm 'Unvalidated] -> Either Error EditingNonterms
forall {v :: Validate}.
EditingNonterms -> [Nonterm v] -> Either Error EditingNonterms
loop EditingNonterms
orig [Nonterm 'Unvalidated]
adds
  where
  loop :: EditingNonterms -> [Nonterm v] -> Either Error EditingNonterms
loop !EditingNonterms
new [] = EditingNonterms -> Either Error EditingNonterms
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EditingNonterms
new
  loop !EditingNonterms
new (Nonterm v
add:[Nonterm v]
rest) = do
    case UpName -> EditingNonterms -> Maybe (Nonterm 'Valid)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Nonterm v
add.nontermName.name EditingNonterms
new of
      Just Nonterm 'Valid
_ -> Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ()) -> Error -> Either Error ()
forall a b. (a -> b) -> a -> b
$ UpName -> Error
IllegalNontermAdded Nonterm v
add.nontermName.name
      Maybe (Nonterm 'Valid)
Nothing -> () -> Either Error ()
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Nonterm 'Valid
okAdd <- Set UpName
-> Map LowName (Name 'Valid LowName)
-> Nonterm v
-> Either Error (Nonterm 'Valid)
forall (v :: Validate).
Set UpName
-> Map LowName (Name 'Valid LowName)
-> Nonterm v
-> Either Error (Nonterm 'Valid)
validateNonterm Set UpName
nts Map LowName (Name 'Valid LowName)
tvs Nonterm v
add
    EditingNonterms -> [Nonterm v] -> Either Error EditingNonterms
loop (UpName -> Nonterm 'Valid -> EditingNonterms -> EditingNonterms
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Nonterm 'Valid
okAdd.nontermName.name Nonterm 'Valid
okAdd EditingNonterms
new) [Nonterm v]
rest

modNonterms :: Set UpName -- ^ known non-terminals for the new language
            -> Map LowName (Name 'Valid LowName) -- ^ known type variables for the new language
            -> Map UpName [ProductionsEdit] -- ^ edits to various non-terminals' productions
            -> EditingNonterms -- ^ old language's non-terminals
            -> Either Error EditingNonterms
modNonterms :: Set UpName
-> Map LowName (Name 'Valid LowName)
-> Map UpName [ProductionsEdit]
-> EditingNonterms
-> Either Error EditingNonterms
modNonterms Set UpName
nts Map LowName (Name 'Valid LowName)
tvs Map UpName [ProductionsEdit]
mods EditingNonterms
orig = do
  [UpName] -> (UpName -> Either Error ()) -> Either Error ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map UpName [ProductionsEdit] -> [UpName]
forall k a. Map k a -> [k]
Map.keys Map UpName [ProductionsEdit]
mods) ((UpName -> Either Error ()) -> Either Error ())
-> (UpName -> Either Error ()) -> Either Error ()
forall a b. (a -> b) -> a -> b
$ \UpName
n -> case UpName -> EditingNonterms -> Maybe (Nonterm 'Valid)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UpName
n EditingNonterms
orig of
    Maybe (Nonterm 'Valid)
Nothing -> Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ()) -> Error -> Either Error ()
forall a b. (a -> b) -> a -> b
$ UpName -> Error
IllegalNontermModified UpName
n
    Just Nonterm 'Valid
_ -> () -> Either Error ()
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  EditingNonterms
-> (UpName -> Nonterm 'Valid -> Either Error (Nonterm 'Valid))
-> Either Error EditingNonterms
forall k (f :: * -> *) a b.
(Ord k, Applicative f) =>
Map k a -> (k -> a -> f b) -> f (Map k b)
forWithKeyM EditingNonterms
orig ((UpName -> Nonterm 'Valid -> Either Error (Nonterm 'Valid))
 -> Either Error EditingNonterms)
-> (UpName -> Nonterm 'Valid -> Either Error (Nonterm 'Valid))
-> Either Error EditingNonterms
forall a b. (a -> b) -> a -> b
$ \UpName
n Nonterm 'Valid
oldNonterm -> case UpName -> Map UpName [ProductionsEdit] -> Maybe [ProductionsEdit]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UpName
n Map UpName [ProductionsEdit]
mods of
    Just [ProductionsEdit]
prodsEdit -> do
      let newName :: Name 'Valid UpName
newName = UpName -> Name -> Name 'Valid UpName
forall n. n -> Name -> Name 'Valid n
ValidName Nonterm 'Valid
oldNonterm.nontermName.name (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ UpName -> String
fromUpName Nonterm 'Valid
oldNonterm.nontermName.name)
      Map UpName (Production 'Valid)
newProductions <- Set UpName
-> Map LowName (Name 'Valid LowName)
-> Map UpName (Production 'Valid)
-> [ProductionsEdit]
-> Either Error (Map UpName (Production 'Valid))
extendProductions Set UpName
nts Map LowName (Name 'Valid LowName)
tvs Nonterm 'Valid
oldNonterm.productions [ProductionsEdit]
prodsEdit
      Nonterm 'Valid -> Either Error (Nonterm 'Valid)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Nonterm 'Valid -> Either Error (Nonterm 'Valid))
-> Nonterm 'Valid -> Either Error (Nonterm 'Valid)
forall a b. (a -> b) -> a -> b
$ Nonterm
        { $sel:nontermName:Nonterm :: Name 'Valid UpName
nontermName = Name 'Valid UpName
newName
        , $sel:productions:Nonterm :: Map UpName (Production 'Valid)
productions = Map UpName (Production 'Valid)
newProductions
        }
    Maybe [ProductionsEdit]
Nothing -> Set UpName
-> Map LowName (Name 'Valid LowName)
-> Nonterm 'Valid
-> Either Error (Nonterm 'Valid)
forall (v :: Validate).
Set UpName
-> Map LowName (Name 'Valid LowName)
-> Nonterm v
-> Either Error (Nonterm 'Valid)
validateNonterm Set UpName
nts Map LowName (Name 'Valid LowName)
tvs Nonterm 'Valid
oldNonterm

delNonterms :: [UpName] -- ^ names of non-terminals to remove
            -> EditingNonterms -- ^ old language's non-terminals
            -> Either Error EditingNonterms
delNonterms :: [UpName] -> EditingNonterms -> Either Error EditingNonterms
delNonterms [UpName]
dels EditingNonterms
orig = EditingNonterms -> [UpName] -> Either Error EditingNonterms
forall {a}. Map UpName a -> [UpName] -> Either Error (Map UpName a)
loop EditingNonterms
orig [UpName]
dels
  where
  loop :: Map UpName a -> [UpName] -> Either Error (Map UpName a)
loop !Map UpName a
new [] = Map UpName a -> Either Error (Map UpName a)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map UpName a
new
  loop !Map UpName a
new (UpName
del:[UpName]
rest) = case UpName -> Map UpName a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UpName
del Map UpName a
new of
    Just a
_ -> Map UpName a -> [UpName] -> Either Error (Map UpName a)
loop (UpName -> Map UpName a -> Map UpName a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete UpName
del Map UpName a
new) [UpName]
rest
    Maybe a
Nothing -> Error -> Either Error (Map UpName a)
forall a b. a -> Either a b
Left (Error -> Either Error (Map UpName a))
-> Error -> Either Error (Map UpName a)
forall a b. (a -> b) -> a -> b
$ UpName -> Error
IllegalNontermDeleted UpName
del

--------------------------------
------ Production Editing ------
--------------------------------

extendProductions :: Set UpName -- ^ known non-terminals for the new language
                  -> Map LowName (Name 'Valid LowName) -- ^ known type variables for the new language
                  -> (Map UpName (Production 'Valid))
                  -> [ProductionsEdit]
                  -> Either Error (Map UpName (Production 'Valid))
extendProductions :: Set UpName
-> Map LowName (Name 'Valid LowName)
-> Map UpName (Production 'Valid)
-> [ProductionsEdit]
-> Either Error (Map UpName (Production 'Valid))
extendProductions Set UpName
nts Map LowName (Name 'Valid LowName)
tvs Map UpName (Production 'Valid)
orig [ProductionsEdit]
mods = do
  let ([Production 'Unvalidated]
additions, [UpName]
deletions) = [ProductionsEdit] -> ([Production 'Unvalidated], [UpName])
partitionProductionsEdits [ProductionsEdit]
mods
  -- NOTE this forM_ is over-restricive because I don't have a way to modify/outright replace productions
  -- forM_ additions $ \add -> case add.prodName.name `elem` deletions of
  --   True -> Left $ IllegalProductionAddedAlsoDeleted add.prodName.name
  --   _ -> pure ()
  Map UpName (Production 'Valid)
restricted <- [UpName]
-> Map UpName (Production 'Valid)
-> Either Error (Map UpName (Production 'Valid))
delProductions [UpName]
deletions Map UpName (Production 'Valid)
orig
  Map UpName (Production 'Valid)
revalidated <- Map UpName (Production 'Valid)
-> (UpName
    -> Production 'Valid -> Either Error (Production 'Valid))
-> Either Error (Map UpName (Production 'Valid))
forall k (f :: * -> *) a b.
(Ord k, Applicative f) =>
Map k a -> (k -> a -> f b) -> f (Map k b)
forWithKeyM Map UpName (Production 'Valid)
restricted ((UpName -> Production 'Valid -> Either Error (Production 'Valid))
 -> Either Error (Map UpName (Production 'Valid)))
-> (UpName
    -> Production 'Valid -> Either Error (Production 'Valid))
-> Either Error (Map UpName (Production 'Valid))
forall a b. (a -> b) -> a -> b
$ \UpName
_ Production 'Valid
oldProd ->
    Set UpName
-> Map LowName (Name 'Valid LowName)
-> Production 'Valid
-> Either Error (Production 'Valid)
forall (v :: Validate).
Set UpName
-> Map LowName (Name 'Valid LowName)
-> Production v
-> Either Error (Production 'Valid)
validateProd Set UpName
nts Map LowName (Name 'Valid LowName)
tvs Production 'Valid
oldProd
  Set UpName
-> Map LowName (Name 'Valid LowName)
-> [Production 'Unvalidated]
-> Map UpName (Production 'Valid)
-> Either Error (Map UpName (Production 'Valid))
addProductions Set UpName
nts Map LowName (Name 'Valid LowName)
tvs [Production 'Unvalidated]
additions Map UpName (Production 'Valid)
revalidated

partitionProductionsEdits :: [ProductionsEdit] -> ([Production 'Unvalidated], [UpName])
partitionProductionsEdits :: [ProductionsEdit] -> ([Production 'Unvalidated], [UpName])
partitionProductionsEdits = ([Production 'Unvalidated], [UpName])
-> [ProductionsEdit] -> ([Production 'Unvalidated], [UpName])
loop ([], [])
  where
  loop :: ([Production 'Unvalidated], [UpName])
-> [ProductionsEdit] -> ([Production 'Unvalidated], [UpName])
loop ([Production 'Unvalidated]
as, [UpName]
ds) [] = ([Production 'Unvalidated] -> [Production 'Unvalidated]
forall a. [a] -> [a]
reverse [Production 'Unvalidated]
as, [UpName] -> [UpName]
forall a. [a] -> [a]
reverse [UpName]
ds)
  loop ([Production 'Unvalidated]
as, [UpName]
ds) (ProductionsEdit
x:[ProductionsEdit]
xs) = case ProductionsEdit
x of
    AddProd Production 'Unvalidated
a -> ([Production 'Unvalidated], [UpName])
-> [ProductionsEdit] -> ([Production 'Unvalidated], [UpName])
loop (Production 'Unvalidated
aProduction 'Unvalidated
-> [Production 'Unvalidated] -> [Production 'Unvalidated]
forall a. a -> [a] -> [a]
:[Production 'Unvalidated]
as, [UpName]
ds) [ProductionsEdit]
xs
    DelProd UpName
d -> ([Production 'Unvalidated], [UpName])
-> [ProductionsEdit] -> ([Production 'Unvalidated], [UpName])
loop ([Production 'Unvalidated]
as, UpName
dUpName -> [UpName] -> [UpName]
forall a. a -> [a] -> [a]
:[UpName]
ds) [ProductionsEdit]
xs

addProductions :: Set UpName -- ^ known non-terminals for the new language
               -> Map LowName (Name 'Valid LowName) -- ^ known type variables for the new language
               -> [Production 'Unvalidated]
               -> (Map UpName (Production 'Valid))
               -> Either Error (Map UpName (Production 'Valid))
addProductions :: Set UpName
-> Map LowName (Name 'Valid LowName)
-> [Production 'Unvalidated]
-> Map UpName (Production 'Valid)
-> Either Error (Map UpName (Production 'Valid))
addProductions Set UpName
nts Map LowName (Name 'Valid LowName)
tvs [Production 'Unvalidated]
adds Map UpName (Production 'Valid)
orig = Map UpName (Production 'Valid)
-> [Production 'Unvalidated]
-> Either Error (Map UpName (Production 'Valid))
forall {v :: Validate}.
Map UpName (Production 'Valid)
-> [Production v] -> Either Error (Map UpName (Production 'Valid))
loop Map UpName (Production 'Valid)
orig [Production 'Unvalidated]
adds
  where
  loop :: Map UpName (Production 'Valid)
-> [Production v] -> Either Error (Map UpName (Production 'Valid))
loop !Map UpName (Production 'Valid)
new [] = Map UpName (Production 'Valid)
-> Either Error (Map UpName (Production 'Valid))
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map UpName (Production 'Valid)
new
  loop !Map UpName (Production 'Valid)
new (Production v
add:[Production v]
rest) = case UpName
-> Map UpName (Production 'Valid) -> Maybe (Production 'Valid)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Production v
add.prodName.name Map UpName (Production 'Valid)
new of
    Just Production 'Valid
_ -> Error -> Either Error (Map UpName (Production 'Valid))
forall a b. a -> Either a b
Left (Error -> Either Error (Map UpName (Production 'Valid)))
-> Error -> Either Error (Map UpName (Production 'Valid))
forall a b. (a -> b) -> a -> b
$ UpName -> Error
IllegalProductionAdded Production v
add.prodName.name
    Maybe (Production 'Valid)
Nothing -> do
      Production 'Valid
okAdd <- Set UpName
-> Map LowName (Name 'Valid LowName)
-> Production v
-> Either Error (Production 'Valid)
forall (v :: Validate).
Set UpName
-> Map LowName (Name 'Valid LowName)
-> Production v
-> Either Error (Production 'Valid)
validateProd Set UpName
nts Map LowName (Name 'Valid LowName)
tvs Production v
add
      Map UpName (Production 'Valid)
-> [Production v] -> Either Error (Map UpName (Production 'Valid))
loop (UpName
-> Production 'Valid
-> Map UpName (Production 'Valid)
-> Map UpName (Production 'Valid)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Production 'Valid
okAdd.prodName.name Production 'Valid
okAdd Map UpName (Production 'Valid)
new) [Production v]
rest

delProductions :: [UpName]
               -> Map UpName (Production 'Valid)
               -> Either Error (Map UpName (Production 'Valid))
delProductions :: [UpName]
-> Map UpName (Production 'Valid)
-> Either Error (Map UpName (Production 'Valid))
delProductions [UpName]
dels Map UpName (Production 'Valid)
orig = Map UpName (Production 'Valid)
-> [UpName] -> Either Error (Map UpName (Production 'Valid))
forall {a}. Map UpName a -> [UpName] -> Either Error (Map UpName a)
loop Map UpName (Production 'Valid)
orig [UpName]
dels
  where
  loop :: Map UpName a -> [UpName] -> Either Error (Map UpName a)
loop !Map UpName a
new [] = Map UpName a -> Either Error (Map UpName a)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map UpName a
new
  loop !Map UpName a
new (UpName
del:[UpName]
rest) = case UpName -> Map UpName a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UpName
del Map UpName a
new of
    Just a
_ -> Map UpName a -> [UpName] -> Either Error (Map UpName a)
loop (UpName -> Map UpName a -> Map UpName a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete UpName
del Map UpName a
new) [UpName]
rest
    Maybe a
Nothing -> Error -> Either Error (Map UpName a)
forall a b. a -> Either a b
Left (Error -> Either Error (Map UpName a))
-> Error -> Either Error (Map UpName a)
forall a b. (a -> b) -> a -> b
$ UpName -> Error
IllegalProductionDeleted UpName
del

---------------------
------ Helpers ------
---------------------

forWithKeyM :: (Ord k, Applicative f) => Map k a -> (k -> a -> f b) -> f (Map k b)
forWithKeyM :: forall k (f :: * -> *) a b.
(Ord k, Applicative f) =>
Map k a -> (k -> a -> f b) -> f (Map k b)
forWithKeyM Map k a
m k -> a -> f b
f = Map k (f b) -> f (Map k b)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => Map k (f a) -> f (Map k a)
sequenceA (Map k (f b) -> f (Map k b)) -> Map k (f b) -> f (Map k b)
forall a b. (a -> b) -> a -> b
$ (k -> a -> f b) -> Map k a -> Map k (f b)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey k -> a -> f b
f Map k a
m