<commit_before>{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}
module Changer.Changes where

{-
This module defines the main data structures, representing a '.typesystem-changes'. It contains the transformations that will be performed
-}

import TypeSystem
import Utils.ToString
import Utils.Utils

import Data.Map hiding (null, filter, lookup)
import qualified Data.Map as M
import Data.List hiding (union)
import Data.List as L
import Data.Maybe
import Data.Bifunctor
import Data.Either

import Control.Monad
import Control.Arrow ((&&&))


data DefaultChange k v
	= Rename k k	-- simply rename the entries
	| Copy k k
	| Delete k
	| New k v
	| Override k v		-- take the entry and edit it slightly
	| OverrideAs k k v	-- take the entry, save it slightly, save it as k2 (and remove the original entry)
	| Edit k v
	| EditAs k k v		-- take the old entry, edit it with the edit function, save it as the new key
	deriving (Show)




type EditFunction k v	= (Bool -> k -> v -> v -> Either String v)

noEditAllowed isOverride k origV oldV
	= Left $ "You want to "++if isOverride then "override" else "edit" ++ " a value, but this is not supported. This is a bug."



applyChangeTo	:: (Show k, Ord k, Eq k) => DefaultChange k v -> Map k v -> Either String (Map k v)
applyChangeTo	= applyChangeTo' noEditAllowed



-- apply a generic change to a generic map
applyChangeTo'	:: (Show k, Ord k, Eq k) =>  EditFunction k v -> DefaultChange k v -> Map k v -> Either String (Map k v)
applyChangeTo' f (Rename ok nk) dict
	= do	dict'	<- applyChangeTo' f (Copy ok nk) dict
		applyChangeTo' f (Delete ok) dict'
applyChangeTo' _ (Delete ok) dict
	= do	v	<- checkExists ok dict $ "You want delete "++show ok++", but it does not exist."
		return $ M.delete ok dict
applyChangeTo' _ (Copy ok nk) dict
	= do	v	<- checkExists ok dict $ "You want to rename/copy "++show ok++" as "++show nk++", but it does not exist."
		_checkTargetNoExists "copy" ok nk dict
		return $ M.insert nk v dict
applyChangeTo' _ (New k v) dict
	= do	checkNoExists k dict $ "You want to introduce "++show k++", but it already exists. Try overriding it in the 'Changes'-section instead."
		return $ M.insert k v dict
applyChangeTo' edit (Override k vNew) dict
	= applyChangeTo' edit (OverrideAs k k vNew) dict
applyChangeTo' edit (OverrideAs k kNew vNew) dict
	= do	vOld	<- checkExists k dict $ "You want to override "++show k++ (if k /= kNew then " as "++show kNew else "") ++", but it does not exist. If you want to introduce this, add it in the 'new' section"
		_checkTargetNoExists "copy" k kNew dict
		v	<- edit True k vOld vNew
		return $ M.insert kNew v $ M.delete k dict
applyChangeTo' edit (Edit k vNew) dict
	= applyChangeTo' edit (EditAs k k vNew) dict
applyChangeTo' edit (EditAs k kNew vNew) dict
	= do	vOld	<- checkExists k dict $ "You want to edit "++show k++(if k /= kNew then " as "++show kNew else "") ++", but it does not exist. If you want to introduce this, add it in the 'new' section"
		_checkTargetNoExists "copy" k kNew dict
		v	<- edit False k vOld vNew
		return $ M.insert kNew v dict

_checkTargetNoExists action kOld kNew dict
	= do	let msg		= "You want to "++action++" "++show kOld++" to "++show kNew++", but the new name already exists. Try deleting it first."
		unless (kOld == kNew) $ checkNoExists kNew dict msg

isNew		:: DefaultChange k v -> Bool
isNew New{}	= True
isNew _		= False



applyAllChanges	:: (Show k, Ord k, Eq k) => EditFunction k v-> [DefaultChange k v] -> Map k v -> Either String (Map k v)
applyAllChanges f changes dict
		= changes & foldM (flip $ applyChangeTo' f) dict


refactorFunc		:: (Eq k) => [DefaultChange k v] -> k -> k
refactorFunc []	k 	= k
refactorFunc (Rename ok nk:rest) k
	| ok == k	= nk
	| otherwise	= refactorFunc rest k
refactorFunc (OverrideAs ok nk _:rest) k
	| ok == k	= nk
	| otherwise	= refactorFunc rest k
refactorFunc (_:rest) k	= refactorFunc rest k







data RelationChangeInfo	
	= RCI 	{ name		:: Name
		, pronounced	:: Maybe String
		, ruleRename	:: Maybe (String, String)}
		deriving (Show)


data RelationChange
	= RDelete Name
	| RCopy   Name RelationChangeInfo
	| RRename Name RelationChangeInfo
		deriving (Show)




data Changes = Changes
			{ changesName	:: Name
			, changedSyntax	:: [DefaultChange TypeName ([BNF], WSMode)]
			, changedFuncs	:: [DefaultChange Name Function]
			, changedRels	:: [DefaultChange Symbol Relation]
			, changedRules	:: [DefaultChange Name Rule]
			} deriving (Show)


checkNoCommon' old new rule section
	= checkNoCommon old new
			(\kv1v2s -> "You want to introduce the "++rule++" "++ showComma (kv1v2s |> fst) ++", but it already exists in the original definition.\n"++
			            "If you want to override the "++rule++", put in in the '"++section++" Changes' section")





editSyntax	:: Bool -> TypeName -> ([BNF], WSMode) -> ([BNF], WSMode) -> Either String ([BNF], WSMode)
-- Case for overwriting
editSyntax True _ old new
		= return new
-- Case for editing (thus adding cases)
editSyntax False n (oldBNFs, oldWS) (newBNF, newWS)
	= inMsg ("While updating syntax rule "++show n) $
	  do	unless (oldWS == newWS) $ Left $ "Whitespace-mode doesn't match. Expected mode (by the original definition): "++toParsable oldWS++", but got "++toParsable newWS
		return (oldBNFs ++ newBNF, newWS)




editFunction	:: Syntax -> Bool -> Name -> Function -> Function -> Either String Function
-- We overwrite. The new function type is a *subtype* of the old type
editFunction syntax True nm old new
	= do	-- check for *subtyping*
		let sType x	= intercalate " -> " (typesOf x)<commit_msg>Added lenses<commit_after>{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, TemplateHaskell #-}
module Changer.Changes where

{-
This module defines the main data structures, representing a '.typesystem-changes'. It contains the transformations that will be performed
-}

import TypeSystem
import Utils.ToString
import Utils.Utils

import Data.Map hiding (null, filter, lookup)
import qualified Data.Map as M
import Data.List hiding (union)
import Data.List as L
import Data.Maybe
import Data.Bifunctor
import Data.Either

import Control.Monad
import Control.Arrow ((&&&))

import Lens.Micro hiding ((&))
import Lens.Micro.TH

data DefaultChange k v
	= Rename k k	-- simply rename the entries
	| Copy k k
	| Delete k
	| New k v
	| Override k v		-- take the entry and edit it slightly
	| OverrideAs k k v	-- take the entry, save it slightly, save it as k2 (and remove the original entry)
	| Edit k v
	| EditAs k k v		-- take the old entry, edit it with the edit function, save it as the new key
	deriving (Show)




type EditFunction k v	= (Bool -> k -> v -> v -> Either String v)

noEditAllowed isOverride k origV oldV
	= Left $ "You want to "++if isOverride then "override" else "edit" ++ " a value, but this is not supported. This is a bug."



applyChangeTo	:: (Show k, Ord k, Eq k) => DefaultChange k v -> Map k v -> Either String (Map k v)
applyChangeTo	= applyChangeTo' noEditAllowed



-- apply a generic change to a generic map
applyChangeTo'	:: (Show k, Ord k, Eq k) =>  EditFunction k v -> DefaultChange k v -> Map k v -> Either String (Map k v)
applyChangeTo' f (Rename ok nk) dict
	= do	dict'	<- applyChangeTo' f (Copy ok nk) dict
		applyChangeTo' f (Delete ok) dict'
applyChangeTo' _ (Delete ok) dict
	= do	v	<- checkExists ok dict $ "You want delete "++show ok++", but it does not exist."
		return $ M.delete ok dict
applyChangeTo' _ (Copy ok nk) dict
	= do	v	<- checkExists ok dict $ "You want to rename/copy "++show ok++" as "++show nk++", but it does not exist."
		_checkTargetNoExists "copy" ok nk dict
		return $ M.insert nk v dict
applyChangeTo' _ (New k v) dict
	= do	checkNoExists k dict $ "You want to introduce "++show k++", but it already exists. Try overriding it in the 'Changes'-section instead."
		return $ M.insert k v dict
applyChangeTo' edit (Override k vNew) dict
	= applyChangeTo' edit (OverrideAs k k vNew) dict
applyChangeTo' edit (OverrideAs k kNew vNew) dict
	= do	vOld	<- checkExists k dict $ "You want to override "++show k++ (if k /= kNew then " as "++show kNew else "") ++", but it does not exist. If you want to introduce this, add it in the 'new' section"
		_checkTargetNoExists "copy" k kNew dict
		v	<- edit True k vOld vNew
		return $ M.insert kNew v $ M.delete k dict
applyChangeTo' edit (Edit k vNew) dict
	= applyChangeTo' edit (EditAs k k vNew) dict
applyChangeTo' edit (EditAs k kNew vNew) dict
	= do	vOld	<- checkExists k dict $ "You want to edit "++show k++(if k /= kNew then " as "++show kNew else "") ++", but it does not exist. If you want to introduce this, add it in the 'new' section"
		_checkTargetNoExists "copy" k kNew dict
		v	<- edit False k vOld vNew
		return $ M.insert kNew v dict

_checkTargetNoExists action kOld kNew dict
	= do	let msg		= "You want to "++action++" "++show kOld++" to "++show kNew++", but the new name already exists. Try deleting it first."
		unless (kOld == kNew) $ checkNoExists kNew dict msg

isNew		:: DefaultChange k v -> Bool
isNew New{}	= True
isNew _		= False



applyAllChanges	:: (Show k, Ord k, Eq k) => EditFunction k v-> [DefaultChange k v] -> Map k v -> Either String (Map k v)
applyAllChanges f changes dict
		= changes & foldM (flip $ applyChangeTo' f) dict


refactorFunc		:: (Eq k) => [DefaultChange k v] -> k -> k
refactorFunc []	k 	= k
refactorFunc (Rename ok nk:rest) k
	| ok == k	= nk
	| otherwise	= refactorFunc rest k
refactorFunc (OverrideAs ok nk _:rest) k
	| ok == k	= nk
	| otherwise	= refactorFunc rest k
refactorFunc (_:rest) k	= refactorFunc rest k









data Changes = Changes
			{ _changesName		:: Name
			, _changedSyntax	:: [DefaultChange TypeName ([BNF], WSMode)]
			, _changedFuncs		:: [DefaultChange Name Function]
			, _changedRels		:: [DefaultChange Symbol Relation]
			, _changedRules		:: [DefaultChange Name Rule]
			} deriving (Show)
makeLenses ''Changes

checkNoCommon' old new rule section
	= checkNoCommon old new
			(\kv1v2s -> "You want to introduce the "++rule++" "++ showComma (kv1v2s |> fst) ++", but it already exists in the original definition.\n"++
			            "If you want to override the "++rule++", put in in the '"++section++" Changes' section")





editSyntax	:: Bool -> TypeName -> ([BNF], WSMode) -> ([BNF], WSMode) -> Either String ([BNF], WSMode)
-- Case for overwriting
editSyntax True _ old new
		= return new
-- Case for editing (thus adding cases)
editSyntax False n (oldBNFs, oldWS) (newBNF, newWS)
	= inMsg ("While updating syntax rule "++show n) $
	  do	unless (oldWS == newWS) $ Left $ "Whitespace-mode doesn't match. Expected mode (by the original definition): "++toParsable oldWS++", but got "++toParsable newWS
		return (oldBNFs ++ newBNF, newWS)




editFunction	:: Syntax -> Bool -> Name -> Function -> Function -> Either String Function
-- We overwrite. The new function type is a *subtype* of the old type
editFunction syntax True nm old new
	= do	-- check for *subtyping*
		let sType x	= intercalate " -> " (typesOf x)
{'fraction_non_alphanumeric': 0.10980819925461321, 'fraction_numerical': 0.000909008271975275, 'mean_word_length': 3.6304713804713806, 'pattern_counts': {'":': 0, '<': 17, '<?xml version=': 0, '>': 65, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3912338', 'n_tokens_mistral': 3742, 'n_tokens_neox': 3559, 'n_words': 1546}