------------------------------------------------------------------------------ -- | This library defines operations to read/parse Prolog programs. -- -- Author : Michael Hanus -- Version: Februarz 2026 ------------------------------------------------------------------------------ {-# OPTIONS_FRONTEND -Wno-incomplete-patterns -Wno-overlapping #-} module Language.Prolog.Read ( readPrologFile, parseProlog ) where import Data.Char ( isAlphaNum, isLower, isSpace, isUpper ) import Control.Search.SetFunctions ( notEmpty, selectValue, set2 ) import Test.Prop import Language.Prolog.Show ( showPlClause, showPlTerm ) import Language.Prolog.Types ---------------------------------------------------------------------------- -- The state used during parsing contains the currently defined operators -- (which are changed by reading an `op` directive). data ParseState = ParseState { opDecls :: [(String,Int,String)] -- operator name / priority / fixity } initParseState :: ParseState initParseState = ParseState stdOps ---------------------------------------------------------------------------- -- | Reads a file containing a Prolog program and returns the Prolog clauses -- contained in this file. readPrologFile :: String -> IO [PlClause] readPrologFile f = readFile f >>= return . parseProlog -- | Parses a string containing a list of Prolog clauses which are returned. parseProlog :: String -> [PlClause] parseProlog = parseClauses initParseState . scanPl -- Parses a sequence of tokens as Prolog clauses where each clause -- is terminated by a dot. parseClauses :: ParseState -> [PlToken] -> [PlClause] parseClauses _ [] = [] parseClauses pst ts@(_:_) = case ts1 of DOT : ts2 -> let cl = term2clause term in cl : parseClauses (addOpDecl cl pst) ts2 _ -> error $ "Missing terminating dot at: " ++ show ts1 where (term, ts1) = parseTerm False pst [] ts -- Adds operators to the state if the clause is an `op` directive. addOpDecl :: PlClause -> ParseState -> ParseState addOpDecl clause pst = case clause of PlDirective [PlLit "op" opargs] -> case opargs of [PlInt prio, PlAtom fix, ops] -> case ops of PlAtom op -> addOps [(op, prio, fix)] opsterm -> addOps (map (\o -> (o, prio, fix)) (opList opsterm)) _ -> error opError _ -> pst where opList ops = case ops of PlStruct "." [PlAtom op, os] -> op : opList os PlAtom "[]" -> [] _ -> error opError opError = "Illegal op directive: " ++ showPlClause clause addOps ops = pst { opDecls = opDecls pst ++ ops } -- Translate a Prolog term into a clause by interpreting the main operators. term2clause :: PlTerm -> PlClause term2clause term = case term of PlStruct f [arg] | f == "?-" -> PlQuery (term2goals arg) PlStruct f [arg] | f == ":-" -> PlDirective (term2goals arg) PlStruct f [l,r] | f == ":-" -> let PlLit p args = term2goal l in PlClause p args (term2goals r) PlStruct f args -> PlClause f args [] PlAtom f -> PlClause f [] [] _ -> error $ "Illegal clause: " ++ showPlTerm term where term2goals t = case t of PlStruct "," [a1,a2] -> term2goal a1 : term2goals a2 _ -> [term2goal t] term2goal t = case t of PlStruct "\\+" [arg] -> PlNeg (term2goals arg) PlStruct ";" [PlStruct "->" [cnd,thn],els] -> PlCond (term2goals cnd) (term2goals thn) (term2goals els) PlStruct f args -> PlLit f args PlAtom f -> PlLit f [] _ -> error $ "Illegal goal: " ++ showPlTerm t -- Parses a sequence of Prolog terms (possibly containing operators). -- The second argument contains the previously parsed terms of this list. -- If the first argument is `True`, the term is terminated by a comma, -- otherwise, a comma is parsed as an infix operator. parseTerm :: Bool -> ParseState -> [PlTerm] -> [PlToken] -> (PlTerm, [PlToken]) parseTerm stopcomma pst pts ts = case ts of VAR s : ts1 -> parseTerm stopcomma pst (PlVar s : pts) ts1 INT n : ts1 -> parseTerm stopcomma pst (PlInt n : pts) ts1 FUNCTOR s : ts1 -> let (args,ts2) = parseCommaTerms pst [] ts1 in case ts2 of RPAREN : ts3 -> parseTerm stopcomma pst (PlStruct s args : pts) ts3 _ -> rightBracketError ts2 ATOM s : ts1 -> parseTerm stopcomma pst (PlAtom s : pts) ts1 COMMA : ts1 | not stopcomma -> parseTerm stopcomma pst (PlAtom "," : pts) ts1 LPAREN : ts1 -> let (term, ts2) = parseTerm False pst [] ts1 in case ts2 of RPAREN : ts3 -> parseTerm stopcomma pst (term : pts) ts3 _ -> rightBracketError ts2 LSQUARE : ts1 -> let (listterm, ts2) = parseList pst ts1 in parseTerm stopcomma pst (listterm : pts) ts2 _ -> (terms2term pst pts, ts) where rightBracketError toks = error $ "Missing right bracket at: " ++ show toks -- Parses a list of comma-separated Prolog terms. parseCommaTerms :: ParseState -> [PlTerm] -> [PlToken] -> ([PlTerm], [PlToken]) parseCommaTerms pst args ts = let (term, ts1) = parseTerm True pst [] ts in case ts1 of COMMA : ts2 -> parseCommaTerms pst (term:args) ts2 _ -> (reverse (term:args), ts1) -- Parses a list in Prolog notation (left square bracket already consumed). parseList :: ParseState -> [PlToken] -> (PlTerm, [PlToken]) parseList pst ts = let (terms, ts1) = parseCommaTerms pst [] ts in case ts1 of RSQUARE : ts2 -> (consList terms (PlAtom "[]"), ts2) BAR : ts2 -> let (tail, ts3) = parseTerm True pst [] ts2 in case ts3 of RSQUARE : ts4 -> (consList terms tail, ts4) _ -> listError ts3 _ -> listError ts1 where listError toks = error $ "Non-terminated list at: " ++ show toks consList [] tail = tail consList (x:xs) tail = PlStruct "." [x, consList xs tail] -- Combines a list of terms (provided as first argument in reverse order) -- into a single term by considering Prolog operator precedences. terms2term :: ParseState -> [PlTerm] -> PlTerm terms2term pst ts = if notEmpty terms then snd (selectValue terms) -- also check for more than one solution... else error $ "Illegal term: " ++ unwords (map showPlTerm (reverse ts)) where terms = set2 opterms2term pst (reverse ts) opterms2term :: ParseState -> [PlTerm] -> (Int, PlTerm) opterms2term _ [t] = (0,t) opterms2term pst (PlAtom f : ts) | isPrefixOp fprio fa tp = (fprio, PlStruct f [t]) where (fprio,fa) = lookupOpInfo f (opDecls pst) (tp,t) = opterms2term pst ts opterms2term pst (ts ++ [PlAtom f]) | isPostfixOp fprio fa tp = (fprio, PlStruct f [t]) where (fprio,fa) = lookupOpInfo f (opDecls pst) (tp,t) = opterms2term pst ts opterms2term pst (ts1 ++ [PlAtom f] ++ ts2) | isInfixOp fprio fa tp1 tp2 = (fprio, PlStruct f [t1,t2]) where (fprio,fa) = lookupOpInfo f (opDecls pst) (tp1,t1) = opterms2term pst ts1 (tp2,t2) = opterms2term pst ts2 isPrefixOp :: Int -> String -> Int -> Bool isPrefixOp fprio fa tprio = fa == "fx" && tprio < fprio || fa == "fy" && tprio <= fprio isPostfixOp :: Int -> String -> Int -> Bool isPostfixOp fprio fa tprio = fa == "xf" && tprio < fprio || fa == "yf" && tprio <= fprio isInfixOp :: Int -> String -> Int -> Int -> Bool isInfixOp fprio fa tp1 tp2 = fa == "xfx" && tp1 < fprio && tp2 < fprio || fa == "yfx" && tp1 <= fprio && tp2 < fprio || fa == "xfy" && tp1 < fprio && tp2 <= fprio lookupOpInfo :: String -> [(String,Int,String)] -> (Int,String) lookupOpInfo op ((op,prio,a):_) = (prio,a) lookupOpInfo op (_:ops) = lookupOpInfo op ops ------------------------------------------------------------------------------ -- A scanner for Prolog. data PlToken = DOT -- a single dot (end of term) | LPAREN | RPAREN | LSQUARE | RSQUARE | BAR | COMMA | VAR String | FUNCTOR String -- a functor, i.e., directly followed by an open bracket | ATOM String -- an atom (not followed by an open bracket) | INT Int deriving Show scanPl :: String -> [PlToken] scanPl s = case dropWhile isSpace s of [] -> [] '%':cs -> scanPl (dropWhile (/='\n') cs) -- skip comment line '(':cs -> LPAREN : scanPl cs ')':cs -> RPAREN : scanPl cs ',':cs -> COMMA : scanPl cs ';':cs -> ATOM ";" : scanPl cs '!':cs -> ATOM "!" : scanPl cs '\'':cs -> scanTickAtom "" cs '.':cs -> if null cs || isSpace (head cs) then DOT : scanPl cs else scanOp "." cs '[':']':cs -> ATOM "[]" : scanPl cs '[':cs -> LSQUARE : scanPl cs ']':cs -> RSQUARE : scanPl cs '|':cs -> BAR : scanPl cs c:cs | isLower c -> scanAtom [c] cs | isUpper c || c == '_' -> scanVar [c] cs | isPrologSpecial c -> scanOp [c] cs | isDigit c -> scanNum [c] cs cs -> error $ "Scan error: " ++ cs scanAtom :: String -> String -> [PlToken] scanAtom pre [] = [ATOM (reverse pre)] scanAtom pre s@(c:cs) | isAlphaNum c || c == '_' = scanAtom (c:pre) cs | c == '(' = FUNCTOR (reverse pre) : scanPl cs | otherwise = ATOM (reverse pre) : scanPl s scanTickAtom :: String -> String -> [PlToken] scanTickAtom pre [] = error $ "Scan error: non-terminated atom: " ++ pre scanTickAtom pre s@(c:cs) | s == "\\" = error $ "Scan error: non-terminated atom: " ++ pre | c == '\\' && head cs == '\'' = scanTickAtom (head cs : pre) cs | c == '\'' = ATOM (reverse pre) : scanPl cs | otherwise = scanTickAtom (c : pre) cs scanVar :: String -> String -> [PlToken] scanVar pre [] = [VAR (reverse pre)] scanVar pre s@(c:cs) | isAlphaNum c || c == '_' = scanVar (c:pre) cs | otherwise = VAR (reverse pre) : scanPl s scanOp :: String -> String -> [PlToken] scanOp pre [] = [ATOM (reverse pre)] scanOp pre s@(c:cs) | isPrologSpecial c = scanOp (c:pre) cs | c == '(' = FUNCTOR (reverse pre) : scanPl cs | otherwise = ATOM (reverse pre) : scanPl s scanNum :: String -> String -> [PlToken] scanNum pre [] = [INT (read (reverse pre))] scanNum pre s@(c:cs) | isDigit c = scanNum (c:pre) cs | otherwise = INT (read (reverse pre)) : scanPl s isPrologSpecial :: Char -> Bool isPrologSpecial = (`elem` "+-*/<=>`\\:.?@#$&^~") ---------------------------------------------------------------------------- -- The standard operators used in Prolog programs. stdOps :: [(String,Int,String)] stdOps = [ (":-",1200,"xfx") , ("-->",1200,"xfx") , (":-",1200,"fx") , ("?-",1200,"fx") , (";",1100,"xfy") , ("dynamic",1150,"fx") , ("function",1150,"fx") -- to specify a function (with result positions) , ("type",1150,"fx") -- to specify data types , ("->",1050,"xfy") , (",",1000,"xfy") , ("\\+",900,"fy") , ("is",700,"xfx") , ("=",700,"xfx"), ("\\=",700,"xfx"), ("=:=",700,"xfx"), ("=\\=",700,"xfx") , ("=..",700,"xfx") , ("=<",700,"xfx"), (">=",700,"xfx"), ("<",700,"xfx"), (">",700,"xfx") , (":",550,"xfy") , ("+",500,"yfx"), ("-",500,"yfx") , ("*",400,"yfx"), ("/",400,"yfx") , ("//",400,"yfx") , ("mod",400,"yfx") , ("rem",400,"yfx") , ("div",400,"yfx") , ("**",200,"xfx") , ("^",200,"xfy") , ("-",200,"fy") , ("+",200,"fy") ] {- Get all currently defined operators in Prolog with: ?- current_op(X,Y,Z), write('("'), write(Z), write('",'), write(X), write(',"'),write(Y), write('")'), nl, fail. -} ---------------------------------------------------------------------------- -- Some testing: testIsColor :: Prop testIsColor = parseProlog "isColor(blue).\nisColor(red)." -=- [PlClause "isColor" [PlAtom "blue"] [],PlClause "isColor" [PlAtom "red"] []] testDirective :: Prop testDirective = parseProlog "?- isColor(42)." -=- [PlQuery [PlLit "isColor" [PlInt 42]]] testList :: Prop testList = parseProlog "append([X|Xs],Ys,[X|Zs]) :- append(Xs,Ys,Zs)." -=- [PlClause "append" [PlStruct "." [PlVar "X",PlVar "Xs"], PlVar "Ys", PlStruct "." [PlVar "X",PlVar "Zs"]] [PlLit "append" [PlVar "Xs",PlVar "Ys",PlVar "Zs"]]] testOpDecl :: Prop testOpDecl = parseProlog ":- op(400, xfy, ++).\n1 ++ 2 ++ 3.\n" -=- [PlDirective [PlLit "op" [PlInt 400,PlAtom "xfy",PlAtom "++"]], PlClause "++" [PlInt 1,PlStruct "++" [PlInt 2,PlInt 3]] []] {- -- Auxiliaries for testing: -- Reads Prolog file and print it. readProg :: String -> IO () readProg f = readPrologFile f >>= putStr . showPlProg ppProg :: String -> IO () ppProg = putStr . showPlProg . parseProlog -- ppProg "isColor(blue).\nisColor(red).\n?- isColor(42)." -- ppProg "%CMT\n:- module(a).\np(X) :- p(f(X)).\np(true).\n?- p(Z).\n" -} ----------------------------------------------------------------------------