Separate out Stat from Term

src/Propa/Prolog/Debug.hs

@@ -12,7 +12,7 @@ import           Propa.Prolog.Parse
 import           Propa.Prolog.Unify
 
 parseAndRun :: T.Text -> T.Text -> IO ()
-parseAndRun dbText termsText = T.putStrLn $ either id id $ do
+parseAndRun dbText statsText = T.putStrLn $ either id id $ do
   db <- parseDb "<input>" dbText
-  terms <- parseTerms "<input>" termsText
+  stats <- parseStats "<input>" statsText
-  pure $ T.intercalate "\n" $ map displayResult $ run db terms
+  pure $ T.intercalate "\n" $ map displayResult $ run db stats

src/Propa/Prolog/Display.hs

@@ -28,33 +28,33 @@ displayName name
       , ("\t", "\\t")
       ]
 
-displayStat :: T.Text -> [Term T.Text] -> T.Text
+displayStat :: Stat T.Text -> T.Text
-displayStat name [] = displayName name
+displayStat (Stat "[|]" [a, b]) = "[" <> displayTerm a <> displayList b
-displayStat name args
+displayStat (Stat name []) = displayName name
+displayStat (Stat name args)
   = displayName name
   <> "("
   <> T.intercalate ", " (map displayTerm args)
   <> ")"
 
 displayList :: Term T.Text -> T.Text
-displayList (Stat "[|]" [a, b]) = "," <> displayTerm a <> displayList b
+displayList (TStat (Stat "[|]" [a, b])) = "," <> displayTerm a <> displayList b
-displayList (Stat "[]" [])      = "]"
+displayList (TStat (Stat "[]" []))      = "]"
-displayList t                   = "|" <> displayTerm t <> "]"
+displayList t                           = "|" <> displayTerm t <> "]"
 
 displayTerm :: Term T.Text -> T.Text
-displayTerm (Var v)             = v
+displayTerm (TVar v)  = v
-displayTerm (Stat "[|]" [a, b]) = "[" <> displayTerm a <> displayList b
+displayTerm (TStat s) = displayStat s
-displayTerm (Stat name args)    = displayStat name args
 
 displayTerms :: [Term T.Text] -> T.Text
 displayTerms terms = T.intercalate ",\n" (map displayTerm terms) <> "."
 
 displayDef :: Def T.Text -> T.Text
-displayDef (Def name args []) = displayStat name args <> "."
+displayDef (Def stat []) = displayStat stat <> "."
-displayDef (Def name args terms)
+displayDef (Def stat stats)
-  =  displayStat name args
+  =  displayStat stat
   <> " :-\n"
-  <> T.intercalate ",\n" (map (\t -> "    " <> displayTerm t) terms)
+  <> T.intercalate ",\n" (map (\t -> "    " <> displayStat t) stats)
   <> "."
 
 displayDefs :: [Def T.Text] -> T.Text
@@ -64,5 +64,5 @@ displayResult :: Map.Map T.Text (Term T.Text) -> T.Text
 displayResult
   = T.intercalate "\n"
   . map (\(k, v) -> k <> " = " <> displayTerm v)
-  . filter (\(k, v) -> v /= Var k)
+  . filter (\(k, v) -> v /= TVar k)
   . Map.assocs

src/Propa/Prolog/Parse.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Propa.Prolog.Parse
-  ( parseTerms
+  ( parseStats
   , parseDb
   ) where
 
@@ -53,23 +53,26 @@ pCons = brackets $ do
   elems <- pTerm `sepBy1` symbol ","
   void $ symbol "|"
   rest <- pTerm
-  pure $ foldr (\a b -> Stat "[|]" [a, b]) rest elems
+  pure $ foldr (\a b -> TStat $ Stat "[|]" [a, b]) rest elems
 
 pList :: Parser (Term T.Text)
 pList = do
   elems <- brackets $ pTerm `sepBy` symbol ","
-  pure $ foldr (\a b -> Stat "[|]" [a, b]) (Stat "[]" []) elems
+  pure $ foldr (\a b -> TStat $ Stat "[|]" [a, b]) (TStat $ Stat "[]" []) elems
 
-pStat :: Parser (T.Text, [Term T.Text])
+pStat :: Parser (Stat T.Text)
 pStat = do
   name <- pName
   terms <- parens (pTerm `sepBy1` symbol ",") <|> pure []
-  pure (name, terms)
+  pure $ Stat name terms
+
+pStats :: Parser [Stat T.Text]
+pStats = (pStat `sepBy1` symbol ",") <* symbol "."
 
 pTerm :: Parser (Term T.Text)
 pTerm
-  =   (Var <$> pVarName)
+  =   (TVar <$> pVarName)
-  <|> (uncurry Stat <$> pStat)
+  <|> (TStat <$> pStat)
   <|> try pCons
   <|> pList
   <|> parens pExpr
@@ -79,18 +82,14 @@ pExpr = makeExprParser pTerm
   [ [ binary "=" ]
   ]
   where
-    binary name = InfixL $ (\a b -> Stat name [a, b]) <$ symbol name
+    binary name = InfixL $ (\a b -> TStat $ Stat name [a, b]) <$ symbol name
-
-pTerms :: Parser [Term T.Text]
-pTerms = (pExpr `sepBy1` symbol ",") <* symbol "."
 
 pDef :: Parser (Def T.Text)
 pDef = do
-  name <- pName
+  stat <- pStat
-  args <- parens (pExpr `sepBy1` symbol ",") <|> pure []
+  stats <- (symbol ":-" *> (pStat `sepBy1` symbol ",")) <|> pure []
-  terms <- (symbol ":-" *> (pExpr `sepBy1` symbol ",")) <|> pure []
   void $ symbol "."
-  pure $ Def name args terms
+  pure $ Def stat stats
 
 pDefs :: Parser [Def T.Text]
 pDefs = many pDef
@@ -102,8 +101,8 @@ parseHelper p path input
   = first (T.pack . errorBundlePretty)
   $ parse (space *> p <* eof) path input
 
-parseTerms :: FilePath -> T.Text -> Either T.Text [Term T.Text]
+parseStats :: FilePath -> T.Text -> Either T.Text [Stat T.Text]
-parseTerms = parseHelper pTerms
+parseStats = parseHelper pStats
 
 parseDb :: FilePath -> T.Text -> Either T.Text (Db T.Text)
 parseDb = parseHelper pDefs

src/Propa/Prolog/Types.hs

@@ -1,41 +1,51 @@
 module Propa.Prolog.Types
-  ( Term(..)
+  ( Stat(..)
+  , Term(..)
   , Def(..)
   , Db
   ) where
 
 import qualified Data.Text as T
 
+data Stat a = Stat T.Text [Term a]
+  deriving (Show, Eq)
+
+instance Functor Stat where
+  fmap f (Stat name terms) = Stat name $ fmap (fmap f) terms
+
+instance Foldable Stat where
+  foldMap f (Stat _ terms) = foldMap (foldMap f) terms
+
+instance Traversable Stat where
+  traverse f (Stat name terms) = Stat name <$> traverse (traverse f) terms
+
 data Term a
-  = Var a
+  = TVar a
-  | Stat T.Text [Term a]
+  | TStat (Stat a)
   deriving (Show, Eq)
 
 instance Functor Term where
-  fmap f (Var a)          = Var $ f a
+  fmap f (TVar a)  = TVar $ f a
-  fmap f (Stat name args) = Stat name $ fmap (fmap f) args
+  fmap f (TStat s) = TStat $ fmap f s
 
 instance Foldable Term where
-  foldMap f (Var a)       = f a
+  foldMap f (TVar a)  = f a
-  foldMap f (Stat _ args) = foldMap (foldMap f) args
+  foldMap f (TStat s) = foldMap f s
 
 instance Traversable Term where
-  traverse f (Var a)          = Var <$> f a
+  traverse f (TVar a)  = TVar <$> f a
-  traverse f (Stat name args) = Stat name <$> traverse (traverse f) args
+  traverse f (TStat s) = TStat <$> traverse f s
 
-data Def a = Def T.Text [Term a] [Term a]
+data Def a = Def (Stat a) [Stat a]
   deriving (Show)
 
 instance Functor Def where
-  fmap f (Def dName dArgs dTerms) = Def dName (fmap f <$> dArgs) (fmap f <$> dTerms)
+  fmap f (Def stat stats) = Def (fmap f stat) (fmap f <$> stats)
 
 instance Foldable Def where
-  foldMap f (Def _ dArgs dTerms) = foldMap (foldMap f) dArgs <> foldMap (foldMap f) dTerms
+  foldMap f (Def stat stats) = foldMap f stat <> foldMap (foldMap f) stats
 
 instance Traversable Def where
-  traverse f (Def dName dArgs dTerms)
+  traverse f (Def stat stats) = Def <$> traverse f stat <*> traverse (traverse f) stats
-    =   Def dName
-    <$> traverse (traverse f) dArgs
-    <*> traverse (traverse f) dTerms
 
 type Db a = [Def a]

src/Propa/Prolog/Unify.hs

@@ -2,7 +2,6 @@
 
 module Propa.Prolog.Unify
   ( run
-  , runOne
   ) where
 
 import           Control.Monad
@@ -36,30 +35,30 @@ data Context = Context
   { cDb     :: Db T.Text
   , cVarIdx :: Int
   , cVars   :: Map.Map Int Int
-  , cTerms  :: Map.Map Int (T.Text, [Term Int])
+  , cStats  :: Map.Map Int (Stat Int)
   } deriving (Show)
 
 newContext :: [Def T.Text] -> Context
 newContext db = Context db 0 Map.empty Map.empty
 
-learnVar :: Int -> Int -> UniM ()
+bindVar :: Int -> Int -> UniM ()
-learnVar k v = modify $ \c -> c{cVars = Map.insert k v $ cVars c}
+bindVar k v = modify $ \c -> c{cVars = Map.insert k v $ cVars c}
 
-learnTerm :: Int -> T.Text -> [Term Int] -> UniM ()
+bindStat :: Int -> Stat Int -> UniM ()
-learnTerm k name args = modify $ \c -> c{cTerms = Map.insert k (name, args) $ cTerms c}
+bindStat k s = modify $ \c -> c{cStats = Map.insert k s $ cStats c}
 
 -- | Look up a variable, first repeatedly in the var map and then the term map.
 -- Returns statements unchanged.
 --
 -- If this returns a variable, then that variable is not bound.
 lookupVar :: Term Int -> UniM (Term Int)
-lookupVar (Var v) = do
+lookupVar (TVar v) = do
   c <- get
   let lastV = follow (cVars c) v
-  pure $ case cTerms c Map.!? lastV of
+  pure $ case cStats c Map.!? lastV of
-    Nothing           -> Var lastV
+    Nothing -> TVar lastV
-    Just (name, args) -> Stat name args
+    Just s  -> TStat s
-lookupVar t@(Stat _ _) = pure t
+lookupVar t@(TStat _) = pure t
 
 -- | A simple state monad transformer over the list monad for easy backtracking.
 -- Needs to be changed when implementing cuts.
@@ -81,33 +80,34 @@ understand a = do
   vmap <- varMap a
   pure (fmap (vmap Map.!) a, vmap)
 
-satisfy :: Term Int -> UniM ()
+satisfy :: Stat Int -> UniM ()
-satisfy (Var _) = pure ()
+satisfy s = do
-satisfy (Stat name args) = do
   c <- get
-  (Def dName dArgs dTerms, _) <- understand =<< lift (cDb c)
+  (Def dStat dStats, _) <- understand =<< lift (cDb c)
-  lift $ guard $ name == dName -- Not sure if 'lift' is really necessary
+  unifyStat s dStat
-  unifyTerms args dArgs
+  satisfyStats dStats
-  satisfyTerms dTerms
 
-satisfyTerms :: [Term Int] -> UniM ()
+satisfyStats :: [Stat Int] -> UniM ()
-satisfyTerms = traverse_ satisfy
+satisfyStats = traverse_ satisfy
+
+unifyStat :: Stat Int -> Stat Int -> UniM ()
+unifyStat (Stat name1 args1) (Stat name2 args2) = do
+  guard $ name1 == name2
+  unifyTerms args1 args2
 
 unify :: Term Int -> Term Int -> UniM ()
 unify t1 t2 = do
   t1' <- lookupVar t1
   t2' <- lookupVar t2
   case (t1', t2') of
-    (Stat name1 args1, Stat name2 args2) -> do
+    (TStat s1, TStat s2) -> unifyStat s1 s2
-      lift $ guard $ name1 == name2
+    (TVar v, TStat s)    -> bindStat v s
-      unifyTerms args1 args2
+    (TStat s, TVar v)    -> bindStat v s
-    (Var v1, Stat name2 args2) -> learnTerm v1 name2 args2
+    (TVar v1, TVar v2)   -> bindVar v1 v2 -- The order shouldn't really matter
-    (Stat name1 args1, Var v2) -> learnTerm v2 name1 args1
-    (Var v1, Var v2) -> learnVar v1 v2 -- The order shouldn't really matter
 
 unifyTerms :: [Term Int] -> [Term Int] -> UniM ()
 unifyTerms t1 t2 = do
-  lift $ guard $ length t1 == length t2
+  guard $ length t1 == length t2
   sequenceA_ $ zipWith unify t1 t2
 
 -- Figuring out how to display the result of the unification
@@ -136,30 +136,26 @@ resolveVars :: Term Int -> UniM (Term Int)
 resolveVars t = do
   t2 <- lookupVar t
   case t2 of
-    (Var v) -> pure $ Var v
+    (TVar v) -> pure $ TVar v
-    (Stat name args) -> do
+    (TStat (Stat name args)) -> TStat . Stat name <$> traverse resolveVars args
-      args2 <- traverse resolveVars args
-      pure $ Stat name args2
 
--- | Helper type so I can resolve variables in multiple terms simultaneously.
+-- | Helper type so I can resolve variables in multiple statements
-newtype Terms a = Terms { unTerms :: [Term a] }
+-- simultaneously.
+newtype Stats a = Stats { unStats :: [Stat a] }
 
-instance Functor Terms where
+instance Functor Stats where
-  fmap f (Terms ts) = Terms $ fmap (fmap f) ts
+  fmap f (Stats ts) = Stats $ fmap (fmap f) ts
 
-instance Foldable Terms where
+instance Foldable Stats where
-  foldMap f (Terms ts) = foldMap (foldMap f) ts
+  foldMap f (Stats ts) = foldMap (foldMap f) ts
 
-run :: Db T.Text -> [Term T.Text] -> [Map.Map T.Text (Term T.Text)]
+run :: Db T.Text -> [Stat T.Text] -> [Map.Map T.Text (Term T.Text)]
-run db terms = map fst $ runStateT helper $ newContext db
+run db stats = map fst $ runStateT helper $ newContext db
   where
     helper = do
-      (terms2, vmap) <- understand $ Terms terms
+      (stats2, vmap) <- understand $ Stats stats
-      satisfyTerms $ unTerms terms2
+      satisfyStats $ unStats stats2
-      tmap <- traverse (resolveVars . Var) vmap
+      tmap <- traverse (resolveVars . TVar) vmap
       c <- get
       let naming = findVarNaming vmap (cVars c) $ Map.elems tmap
       pure $ fmap (naming Map.!) <$> tmap
-
-runOne :: Db T.Text -> Term T.Text -> [Map.Map T.Text (Term T.Text)]
-runOne db term = run db [term]