Mercurial > repo
view interps/rhotor/Parser.hs @ 12493:885661512b17 draft
<int-e> le//rn schwartzian//In 1987, Yogurt introduced a better way to rank Schwartz users: Rather than holding an annual tournament, users would take a series of standardized tests adminstered by official Schwartz centers, and would then be ranked according to the results. This lead to the Schwartzian transform because it allowed many more users to be ranked.
author | HackEso <hackeso@esolangs.org> |
---|---|
date | Fri, 12 Jan 2024 07:24:55 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
module Parser (parse) where import Data.List import Uniqs import Node data Token = Variable String | NewVariable String | TFunction | Fail | TCons | TLT | TGT | String String | Number Integer | SubExp [Token] | NCons Token Token | NFunction Token Token Token | NApplication Token Token | TNil parse :: String -> Node parse x = tokenToNode (parseIntern (tokenize x)) [] Root {- Tokenizer -} tokenize :: String -> [Token] tokenize [] = [] tokenize ( '/' :t) = (TFunction : tokenize t) tokenize ( '\\':t) = (Fail : tokenize t) tokenize ( ',' :t) = (TCons : tokenize t) tokenize ( '<' :t) = (TLT : tokenize t) tokenize ( '>' :t) = (TGT : tokenize t) tokenize ( '%' :( '"' :t )) = (String text : tokenize q) where (text,q) = (textTokenize t) tokenize ( '%' :( '\'' :(c:t))) = (Number (toInteger (fromEnum c)) : tokenize t) tokenize ( '%' :t) = (Number (read text) : tokenize q) where (text,q) = (numberTokenize t) tokenize ( ':' :t) = (NewVariable text : tokenize q) where (text,q) = (varTokenize t) tokenize y@( x :t) | (x >= 'a' && x <= 'z') = (Variable text : tokenize q) | elem x ". \n\t\r" = tokenize t | (x >= 'A' && x <= 'Z') = tokenize t where (text,q) = (varTokenize y) textTokenize :: String -> (String,String) textTokenize ( '\\' : ( 'n' :t) ) = (( '\n' :text), q) where (text,q) = (textTokenize t) textTokenize ( '\\' : ( x :t) ) = ((x:text), q) where (text,q) = (textTokenize t) textTokenize ( '"' : t) = ("",t) textTokenize ( x : t) = ((x:text), q) where (text,q) = (textTokenize t) numberTokenize :: String -> (String,String) numberTokenize [] = ("",[]) numberTokenize y@( x : t) | x >= '0' && x <= '9' = ((x:text), q) | otherwise = ("",y) where (text,q) = (numberTokenize t) varTokenize :: String -> (String,String) varTokenize [] = ("",[]) varTokenize y@( x : t) | x >= 'a' && x <= 'z' = ((x:text), q) | otherwise = ("",y) where (text,q) = (varTokenize t) instance Show Token where show (Variable x) = "Variable " ++ (show x) show (NewVariable x) = "NewVariable " ++ (show x) show (TFunction) = "TFunction" show (Fail) = "Fail" show (TCons) = "TCons" show (TLT) = "TLT" show (TGT) = "TGT" show (String x) = "String " ++ (show x) show (Number x) = "Number " ++ (show x) show (SubExp x) = "SubExp " ++ (show x) show (NCons x y) = "NCons (" ++ (show x) ++ ") (" ++ (show y) ++ ")" show (NFunction x y z) = "NFunction (" ++ (show x) ++ ") (" ++ (show y) ++ ") (" ++ (show z) ++ ")" show (NApplication x y) = "NApplication (" ++ (show x) ++ ") (" ++ (show y) ++ ")" show (TNil) = "TNil" instance Eq Token where (==) TFunction TFunction = True (==) Fail Fail = True (==) _ _ = False {- Parser -} parseIntern :: [Token] -> Token parseIntern x = stripSubExp (head (parseApplication (parseCons (fst (parseFunctions (fst (parseTT (expandNumbers (expandStrings x))))))))) onReverse :: ([a] -> [a]) -> [a] -> [a] onReverse x y = (reverse (x (reverse y))) expandStrings :: [Token] -> [Token] expandStrings [] = [] expandStrings ((String x):rest) = (xtail (concatMap toNums x)) ++ (expandStrings rest) where toNums x = [TCons,TLT,Number (toInteger (fromEnum x)),TGT] xtail [] = [] xtail (h:t) = t expandStrings (h:rest) = h:(expandStrings rest) expandNumbers :: [Token] -> [Token] expandNumbers [] = [] expandNumbers ((Number x):rest) = (toNils x) ++ (expandNumbers rest) where toNils 0 = [TNil] toNils (n+1) = TNil:(TCons:(toNils n)) expandNumbers (h:rest) = h:(expandNumbers rest) parseTT :: [Token] -> ([Token],[Token]) parseTT [] = ([],[]) parseTT (TGT:y) = ([],y) parseTT (TLT:y) = ((SubExp frst:snd),thrd) where (frst,lst) = parseTT y (snd,thrd) = parseTT lst parseTT (x:y) = ((x:frst),lst) where (frst,lst) = parseTT y partitionWhen :: (a -> Bool) -> [a] -> Maybe ([a],[a]) partitionWhen f x@(h:t) = if f h then Just ([],x) else case (partitionWhen f t) of Nothing -> Nothing Just (q,r) -> Just ((h:q),r) partitionWhen f [] = Nothing partitionWhen2 :: (a -> Bool) -> [a] -> Maybe ([a],a,[a]) partitionWhen2 f x = case (partitionWhen f x) of Nothing -> Nothing Just (q,h:t)-> Just (q,h,t) parseFunctions :: [Token] -> ([Token],[Token]) parseFunctions x = case (partitionWhen2 (\y -> y == TFunction || y == Fail) x) of Nothing -> ((parseSubFunctions x),[]) Just (fl,Fail,frst) -> (fl,frst) Just (a,TFunction,c) -> let (def,rst) = parseFunctions c (frst,lrst) = parseFunctions rst in ([NFunction (SubExp (fst (parseFunctions a))) (SubExp (fst (parseFunctions def))) (SubExp (fst (parseFunctions frst)))],lrst) parseSubFunctions :: [Token] -> [Token] parseSubFunctions [] = [] parseSubFunctions ((SubExp x):t) = (SubExp (fst (parseFunctions x))):(parseSubFunctions t) parseSubFunctions (x:t) = x:(parseSubFunctions t) parseApplication :: [Token] -> [Token] parseApplication x = foldr iteration [] (reverse x) where iteration itema (itemb:rest) = (NApplication itemb (parseSubApplication itema)):rest iteration item [] = [parseSubApplication item] parseSubApplication :: Token -> Token parseSubApplication (SubExp x) = SubExp (parseApplication x) parseSubApplication (NFunction x y z) = NFunction (parseSubApplication x) (parseSubApplication y) (parseSubApplication z) parseSubApplication (NCons x y) = NCons (parseSubApplication x) (parseSubApplication y) parseSubApplication x = x parseCons :: [Token] -> [Token] parseCons x = foldr iteration [] x where iteration itema (TCons:(itemb:rest)) = (NCons (parseSubCons itema) itemb):rest iteration item list = (parseSubCons item):list parseSubCons :: Token -> Token parseSubCons (SubExp x) = SubExp (parseCons x) parseSubCons (NFunction x y z) = NFunction (parseSubCons x) (parseSubCons y) (parseSubCons z) parseSubCons x = x stripSubExp :: Token -> Token stripSubExp (SubExp [a]) = stripSubExp a stripSubExp (SubExp []) = TNil stripSubExp (NCons a b) = NCons (stripSubExp a) (stripSubExp b) stripSubExp (NFunction a b c) = NFunction (stripSubExp a) (stripSubExp b) (stripSubExp c) stripSubExp (NApplication a b) = NApplication (stripSubExp a) (stripSubExp b) stripSubExp a = a tokenToNode :: Token -> [(String,Uniqs)] -> Uniqs -> Node tokenToNode TNil _ _ = Nil tokenToNode (NCons a b) tab cn = Cons (tokenToNode a tab (A cn)) (tokenToNode b tab (B cn)) tokenToNode (NApplication a b) tab cn = Application (tokenToNode a tab (A cn)) (tokenToNode b tab (B cn)) tokenToNode (NFunction a b c) tab cn = let (ac,ntab) = functionPtrnToNode a tab (C cn) in (Function ac (tokenToNode b ntab (A cn)) (tokenToNode c tab (B cn))) tokenToNode (Variable n) tab _ = let Just a = (lookup n tab) in (Symbol a) functionPtrnToNode :: Token -> [(String,Uniqs)] -> Uniqs -> (Node,[(String,Uniqs)]) functionPtrnToNode TNil tab _ = (Nil,tab) functionPtrnToNode (NCons a b) tab cn = let (newa,tab2) = functionPtrnToNode a tab (A cn) (newb,tab3) = functionPtrnToNode b tab2 (B cn) in ((Cons newa newb),tab3) functionPtrnToNode (NApplication a b) tab cn = let (newa,tab2) = functionPtrnToNode a tab (A cn) (newb,tab3) = functionPtrnToNode b tab2 (B cn) in ((Application newa newb),tab3) functionPtrnToNode a@(NFunction _ _ _) tab cn = ((tokenToNode a tab cn),tab) functionPtrnToNode (Variable n) tab cn = case (lookup n tab) of Just a -> (Symbol a,tab) Nothing -> (Symbol cn,((n,cn):tab)) functionPtrnToNode (NewVariable n) tab cn = (Symbol cn,((n,cn):(deleteBy filter (n,cn) tab))) where filter (a,_) (b,_) = a == b