diff --git a/NanoProlog.cabal b/NanoProlog.cabal --- a/NanoProlog.cabal +++ b/NanoProlog.cabal @@ -1,5 +1,5 @@ Name: NanoProlog -Version: 0.2.3.3 +Version: 0.3 Synopsis: Very small interpreter for a Prolog-like language Description: This package was developed to demonstrate the ideas behind the Prolog language. It contains a very small interpreter @@ -29,16 +29,23 @@ Main-is: Main.hs Build-depends: - base >= 4 && < 5, - uu-parsinglib >= 2.7.1 + base >= 4 && < 5, + uu-parsinglib >= 2.7.1 && < 2.8 + GHC-Options: -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-unused-do-bind + Library - Build-Depends: base >= 4.0 && < 5.0, - uu-parsinglib >= 2.7.1, - ListLike == 3.1.*, - containers == 0.4.* + Build-Depends: base >= 4.0 && < 5.0, + uu-parsinglib >= 2.7.1 && < 2.8, + ListLike == 3.1.*, + containers == 0.4.* Hs-Source-Dirs: src Exposed-modules: Language.Prolog.NanoProlog.NanoProlog, + Language.Prolog.NanoProlog.Parser, Language.Prolog.NanoProlog.Interpreter Extensions: Rank2Types, FlexibleContexts, TypeSynonymInstances, FlexibleInstances + GHC-Options: -Wall -fwarn-tabs -funbox-strict-fields + -fno-warn-unused-do-bind + diff --git a/src/Language/Prolog/NanoProlog/Interpreter.hs b/src/Language/Prolog/NanoProlog/Interpreter.hs --- a/src/Language/Prolog/NanoProlog/Interpreter.hs +++ b/src/Language/Prolog/NanoProlog/Interpreter.hs @@ -1,9 +1,11 @@ module Language.Prolog.NanoProlog.Interpreter where import Language.Prolog.NanoProlog.NanoProlog +import Language.Prolog.NanoProlog.Parser import Text.ParserCombinators.UU import System.Environment import System.IO +import Data.List -- * Running the Interpreter -- ** The main interpreter @@ -27,15 +29,17 @@ -- | `loop` ask for a goal, and enuartes all solutions found, each preceded by -- a trace conatining the rules applied in a tree-like fashion loop :: [Rule] -> IO () -loop rules = do putStrLn "goal? " - s <- getLine - unless (s == "quit") $ - do let (goal, errors) = startParse pTerm s - if null errors - then printSolutions (solve rules emptyEnv [("0",goal)]) - else do putStrLn "Some goals were expected:" - mapM_ print errors - loop rules +loop rules = do + putStrLn "goal? " + s <- getLine + unless (s == "quit") $ + do let (goal, errors) = startParse pTerm s + if null errors + then printSolutions (solve rules emptyEnv [("0",goal)]) + else do putStrLn "Some goals were expected:" + print goal + mapM_ print errors + loop rules -- | `printSolutions` takes the result of a treewalk, which constructs -- all the proofs, and pairs them with their final @@ -46,11 +50,10 @@ -- directly stemming from the data base are not printed. This makes -- the proofs much shorter, but a bit less complete. printSolutions :: Result -> IO () -printSolutions result = sequence_ - [ do sequence_ [ putStrLn (prefix ++ " " ++ show (subst env pr)) - | (prefix, pr) <- reverse proof - ] - putStr "substitution: " - putStrLn (show env) - void getLine - | (proof, env) <- enumerateDepthFirst [] result ] +printSolutions result = + sequence_ (intersperse (putStr "next?" >> void getLine) + [ do mapM_ (\(prefix, pr) -> putStrLn (prefix ++ " " ++ show (subst env pr))) + (reverse proof) + putStr "substitution: " + print env + | (proof, env) <- enumerateDepthFirst [] result ]) diff --git a/src/Language/Prolog/NanoProlog/NanoProlog.hs b/src/Language/Prolog/NanoProlog/NanoProlog.hs --- a/src/Language/Prolog/NanoProlog/NanoProlog.hs +++ b/src/Language/Prolog/NanoProlog/NanoProlog.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - module Language.Prolog.NanoProlog.NanoProlog ( Env(..) , UpperCase @@ -18,23 +13,13 @@ , emptyEnv , enumerateDepthFirst , matches - , pFun - , pRule - , pTerm - , pCons - , pTerms , solve - , startParse , unify ) where -import Data.ListLike.Base (ListLike) import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as M -import Text.ParserCombinators.UU -import Text.ParserCombinators.UU.BasicInstances -import Text.ParserCombinators.UU.Utils -- * Types type UpperCase = String @@ -146,9 +131,13 @@ instance Show Term where show (Var i) = i show (Fun i [] ) = i - show (Fun "->" [f,a]) = "(" ++ show f ++ ")" ++ " -> " ++ show a - show (Fun "[]" [l]) = "[" ++ show l ++ "]" - show (Fun i ts ) = i ++ "(" ++ showCommas ts ++ ")" + show (Fun "->" [f@(Fun "->" _) ,a]) = "(" ++ show f ++ ")" ++ " -> " ++ show a + show (Fun "->" [f ,a]) = show f ++ " -> " ++ show a + show (Fun "cons" [h@(Fun "->" _),t]) = "(" ++ show h ++ ")" ++ ":" ++ show t + show (Fun "cons" [h@(Fun "cons" _),t]) = "(" ++ show h ++ ")" ++ ":" ++ show t + show (Fun "cons" [h ,t]) = show h ++ ":" ++ show t + show (Fun "[]" [l]) = "[" ++ show l ++ "]" + show (Fun i ts ) = i ++ "(" ++ showCommas ts ++ ")" instance Show Rule where show (t :<-: [] ) = show t ++ "." @@ -156,32 +145,3 @@ showCommas :: Show a => [a] -> String showCommas l = intercalate ", " (map show l) - --- ** Parsing Rules and Terms -startParse :: (ListLike s b, Show b) => - P (Str b s LineColPos) a -> s -> (a, [Error LineColPos]) -startParse p inp = parse ((,) <$> p <*> pEnd) - $ createStr (LineColPos 0 0 0) inp - -pSepDot :: Parser String -> Parser [String] -pSepDot p = (:) <$> p <*> pList ((:) <$> pDot <*> p) - -pTerm, pFactor, pCons, pVar, pFun :: Parser Term -pTerm = pChainr ((\ f a -> Fun "->" [f, a]) <$ pToken "->") pCons -pCons = (\a b -> Fun "cons" [a, b]) <$> pFactor <* pToken ":" <*> pCons - <|> pFactor -pFactor = pVar - <|> pFun - <|> pParens pTerm - -pVar = Var <$> lexeme ((++) <$> pList1 pUpper <*> (concat <$> pSepDot (pList1 pDigit) `opt` [])) -pFun = Fun <$> pLowerCase <*> (pParens pTerms `opt` []) - <|> Fun "[]" <$> pBrackets ((:[]) <$> pTerm) - where pLowerCase :: Parser String - pLowerCase = lexeme ((:) <$> pLower <*> pList (pLetter <|> pDigit)) - -pRule :: Parser Rule -pRule = (:<-:) <$> pFun <*> (pSymbol ":-" *> pTerms `opt` []) <* pDot - -pTerms :: Parser [Term] -pTerms = pList1Sep pComma pTerm diff --git a/src/Language/Prolog/NanoProlog/Parser.hs b/src/Language/Prolog/NanoProlog/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/Prolog/NanoProlog/Parser.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Language.Prolog.NanoProlog.Parser ( + pFun + , pRule + , pTerm + , pCons + , pTerms + , startParse + ) where + +import Data.ListLike.Base (ListLike) +import Language.Prolog.NanoProlog.NanoProlog +import Text.ParserCombinators.UU +import Text.ParserCombinators.UU.BasicInstances +import Text.ParserCombinators.UU.Utils + +-- ** Parsing Rules and Terms +startParse :: (ListLike s b, Show b) => + P (Str b s LineColPos) a -> s -> (a, [Error LineColPos]) +startParse p inp = parse ((,) <$> p <*> pEnd) + $ createStr (LineColPos 0 0 0) inp + +pSepDot :: Parser String -> Parser [String] +pSepDot p = (:) <$> p <*> pList ((:) <$> pDot <*> p) + +pTerm, pFactor, pCons, pVar, pFun :: Parser Term +pTerm = pChainr ((\ f a -> Fun "->" [f, a]) <$ pToken "->") pCons +pCons = pChainr ((\ h t -> Fun "cons" [h, t]) <$ pToken ":" ) pFactor +pFactor = pVar + <|> pFun + <|> pParens pTerm + +pVar = Var <$> lexeme ((++) <$> pList1 pUpper <*> (concat <$> pSepDot (pList1 pDigit) `opt` [])) +pFun = Fun <$> pLowerCase <*> (pParens pTerms `opt` []) + <|> Fun "[]" <$> pBrackets ((:[]) <$> pTerm) + where pLowerCase :: Parser String + pLowerCase = lexeme ((:) <$> pLower <*> pList (pLetter <|> pDigit)) + +pRule :: Parser Rule +pRule = (:<-:) <$> pFun <*> (pSymbol ":-" *> pTerms `opt` []) <* pDot + +pTerms :: Parser [Term] +pTerms = pList1Sep pComma pTerm +