<commit_before>module ParamRules(expand_rules) where

import AbsSyn
import Control.Monad.Writer
import Control.Monad.Error
import Control.Monad.Instances()  -- mtl is broken, so we use Either monad
import Data.List(partition,intersperse)
import qualified Data.Set as S
import qualified Data.Map as M    -- XXX: Make it work with old GHC.

expand_rules :: [Rule] -> Either String [Rule1]
expand_rules rs = do let (funs,rs1) = split_rules rs
                     (as,is) <- runM2 (mapM (`inst_rule` []) rs1)
                     bs <- make_insts funs (S.toList is) S.empty
                     return (as++bs)

type RuleName = String
type Inst     = (RuleName, [RuleName])
type Funs     = M.Map RuleName Rule
type Rule1    = (RuleName,[Prod1],Maybe String)
type Prod1    = ([RuleName],String,Int,Maybe String)

inst_name :: Inst -> RuleName
inst_name (f,[])  = f
inst_name (f,xs)  = f ++ "(" ++ concat (intersperse "," xs) ++ ")"


-- | A renaming substitution used when we instantiate a parameterized rule.
type Subst    = [(RuleName,RuleName)]
type M1       = Writer (S.Set Inst)
type M2       = ErrorT String M1

-- | Collects the instances arising from a term.
from_term :: Subst -> Term -> M1 RuleName
from_term s (App f [])  = return $ case lookup f s of
                            Just g  -> g
                            Nothing -> f

from_term s (App f ts)  = do xs <- from_terms s ts
                             let i = (f,xs)
                             tell (S.singleton i)
                             return $ inst_name i

-- | Collects the instances arising from a list of terms.
from_terms :: Subst -> [Term] -> M1 [RuleName]
from_terms s ts = mapM (from_term s) ts

-- XXX: perhaps change the line to the line of the instance
inst_prod :: Subst -> Prod -> M1 Prod1
inst_prod s (ts,c,l,p)  = do xs <- from_terms s ts
                             return (xs,c,l,p)

inst_rule :: Rule -> [RuleName] -> M2 Rule1
inst_rule (x,xs,ps,t) ts  = do s <- build xs ts []
                               ps1 <- lift $ mapM (inst_prod s) ps
                               let y = inst_name (x,ts)
                               return (y,ps1,t)    -- XXX: type?
  where build (x:xs) (t:ts) m = build xs ts ((x,t):m)
        build [] [] m  = return m
        build xs [] _  = err ("Need " ++ show (length xs) ++ " more arguments")
        build _ xs _   = err (show (length xs) ++ " argumnets too many.")

        err m = throwError ("In " ++ inst_name (x,ts) ++ ": " ++ m)

make_rule :: Funs -> Inst -> M2 Rule1
make_rule funs (f,xs) =
  case M.lookup f funs of
    Just r  -> inst_rule r xs
    Nothing -> throwError ("Undefined rule: " ++ f)

<commit_msg>Fix warnings in ParamRules<commit_after>module ParamRules(expand_rules) where

import AbsSyn
import Control.Monad.Writer
import Control.Monad.Error
import Control.Monad.Instances()  -- mtl is broken, so we use Either monad
import Data.List(partition,intersperse)
import qualified Data.Set as S
import qualified Data.Map as M    -- XXX: Make it work with old GHC.

expand_rules :: [Rule] -> Either String [Rule1]
expand_rules rs = do let (funs,rs1) = split_rules rs
                     (as,is) <- runM2 (mapM (`inst_rule` []) rs1)
                     bs <- make_insts funs (S.toList is) S.empty
                     return (as++bs)

type RuleName = String
type Inst     = (RuleName, [RuleName])
type Funs     = M.Map RuleName Rule
type Rule1    = (RuleName,[Prod1],Maybe String)
type Prod1    = ([RuleName],String,Int,Maybe String)

inst_name :: Inst -> RuleName
inst_name (f,[])  = f
inst_name (f,xs)  = f ++ "(" ++ concat (intersperse "," xs) ++ ")"


-- | A renaming substitution used when we instantiate a parameterized rule.
type Subst    = [(RuleName,RuleName)]
type M1       = Writer (S.Set Inst)
type M2       = ErrorT String M1

-- | Collects the instances arising from a term.
from_term :: Subst -> Term -> M1 RuleName
from_term s (App f [])  = return $ case lookup f s of
                            Just g  -> g
                            Nothing -> f

from_term s (App f ts)  = do xs <- from_terms s ts
                             let i = (f,xs)
                             tell (S.singleton i)
                             return $ inst_name i

-- | Collects the instances arising from a list of terms.
from_terms :: Subst -> [Term] -> M1 [RuleName]
from_terms s ts = mapM (from_term s) ts

-- XXX: perhaps change the line to the line of the instance
inst_prod :: Subst -> Prod -> M1 Prod1
inst_prod s (ts,c,l,p)  = do xs <- from_terms s ts
                             return (xs,c,l,p)

inst_rule :: Rule -> [RuleName] -> M2 Rule1
inst_rule (x,xs,ps,t) ts  = do s <- build xs ts []
                               ps1 <- lift $ mapM (inst_prod s) ps
                               let y = inst_name (x,ts)
                               return (y,ps1,t)    -- XXX: type?
  where build (x':xs') (t':ts') m = build xs' ts' ((x',t'):m)
        build [] [] m  = return m
        build xs' [] _  = err ("Need " ++ show (length xs') ++ " more arguments")
        build _ ts' _   = err (show (length ts') ++ " arguments too many.")

        err m = throwError ("In " ++ inst_name (x,ts) ++ ": " ++ m)

make_rule :: Funs -> Inst -> M2 Rule1
make_rule funs (f,xs) =
  case M.lookup f funs of
    Just r  -> inst_rule r xs
    Nothing -> throwError ("Undefined rule: " ++ f)

runM2 :: ErrorT e (Writer w) a -> Either e (a, w)
{'fraction_non_alphanumeric': 0.12291434927697442, 'fraction_numerical': 0.007601038190582128, 'mean_word_length': 2.0207166853303473, 'pattern_counts': {'":': 2, '<': 15, '<?xml version=': 0, '>': 36, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 6, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7274548', 'n_tokens_mistral': 1795, 'n_tokens_neox': 1725, 'n_words': 611}