├── .gitignore ├── Setup.hs ├── .travis.yml ├── test └── Tests.hs ├── Molog.cabal ├── LICENSE ├── src ├── Molog │ └── Prelude.hs └── Molog.hs └── examples └── Infer.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | dist/ -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | 3 | before_install: cabal update 4 | 5 | install: cabal install --only-dependencies --enable-tests --force-reinstalls 6 | -------------------------------------------------------------------------------- /test/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Main where 3 | 4 | import Control.Monad 5 | 6 | import Molog 7 | 8 | import Test.HUnit 9 | import Test.Framework 10 | import Test.Framework.Providers.HUnit 11 | import Test.Framework.TH 12 | 13 | main = $(defaultMainGenerator) 14 | 15 | case_2vars = runMolog (reify =<< test) @=? [Just 5] 16 | where test :: Molog s (Term s Int) 17 | test = do x <- fresh 18 | y <- fresh 19 | x `unify` (Val 5) 20 | x `unify` y 21 | return y 22 | 23 | case_2vars_pair = runMolog (reify =<< test) @=? [Just (5, 5)] 24 | where test :: Molog s (Term s (Term s Int, Term s Int)) 25 | test = do x <- fresh 26 | y <- fresh 27 | x `unify` (Val 5) 28 | x `unify` y 29 | p <- fresh 30 | p `unify` (Val (x, y)) 31 | return p 32 | 33 | case_disj = runMolog (reify =<< test) @=? [Just 5, Just 6] 34 | where test :: Molog s (Term s Int) 35 | test = do x <- fresh 36 | msum [ x `unify` (Val 5) 37 | , x `unify` (Val 5) >> x `unify` (Val 6) 38 | , x `unify` (Val 6) 39 | ] 40 | return x 41 | 42 | -------------------------------------------------------------------------------- /Molog.cabal: -------------------------------------------------------------------------------- 1 | Name: Molog 2 | Version: 0.1 3 | Synopsis: Molog: Typed Logic Programming 4 | License: BSD3 5 | License-file: LICENSE 6 | Author: Adam C. Foltzer 7 | Maintainer: acfoltzer@gmail.com 8 | Category: Language 9 | Build-type: Simple 10 | Cabal-version: >=1.14 11 | 12 | Library 13 | Exposed-modules: Molog 14 | -- Molog.Prelude 15 | Build-depends: base >= 4 && < 5, 16 | containers >= 0.4, 17 | logict >= 0.5, 18 | mtl >= 2.1, 19 | persistent-refs >= 0.3, 20 | ref-fd >= 0.3 21 | Hs-source-dirs: src 22 | 23 | Test-Suite Tests 24 | Type: exitcode-stdio-1.0 25 | hs-source-dirs: test, src 26 | Main-is: Tests.hs 27 | Build-depends: base >= 4 && < 5, 28 | containers >= 0.4, 29 | logict >= 0.5, 30 | mtl >= 2.1, 31 | persistent-refs >= 0.3, 32 | ref-fd >= 0.3, 33 | HUnit >= 1.2, 34 | test-framework >= 0.8, 35 | test-framework-hunit >= 0.3, 36 | test-framework-th >= 0.2 37 | 38 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012-2013, Adam C. Foltzer 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Adam C. Foltzer nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/Molog/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE PackageImports #-} 3 | 4 | module Molog.Prelude where 5 | 6 | import Molog 7 | 8 | import Control.Applicative 9 | import Control.Monad hiding (mapM) 10 | import "mtl" Control.Monad.Reader hiding (mapM) 11 | import "mtl" Control.Monad.State hiding (mapM) 12 | 13 | import Data.Map (Map) 14 | import qualified Data.Map as Map 15 | 16 | import Prelude hiding (mapM) 17 | 18 | data LogicList a = Nil 19 | | Cons (LogicVal a) (LogicVal (LogicList a)) 20 | deriving (Eq, Show) 21 | 22 | instance Functor LogicList where 23 | fmap _ Nil = Nil 24 | fmap f (Cons hd tl) = Cons (f <$> hd) ((fmap f) <$> tl) 25 | 26 | fromList :: [a] -> LogicList a 27 | fromList [] = Nil 28 | fromList (x:xs) = Cons (Val x) (Val $ fromList xs) 29 | 30 | toList :: LogicList a -> Maybe [a] 31 | toList Nil = return [] 32 | toList (Cons (Val x) (Val xs)) = (:) x <$> toList xs 33 | toList _ = mzero 34 | 35 | mapM :: Monad m => (a -> m b) -> LogicList a -> m (LogicList b) 36 | mapM _ Nil = return Nil 37 | mapM f (Cons x xs) = do 38 | v <- case x of 39 | Var id -> return $ Var id 40 | Val x -> do v <- f x; return $ Val v 41 | case xs of 42 | Var id -> return $ Cons v (Var id) 43 | Val xs -> do vs <- mapM f xs 44 | return $ Cons v (Val vs) 45 | 46 | instance Unifiable a => Unifiable (LogicList a) where 47 | unify xs ys = do 48 | s <- getSubst 49 | case (walk xs s, walk ys s) of 50 | (xs' , ys' ) | xs' == ys' -> return () 51 | (Var id , ys' ) -> modifySubst (extendS (Var id) ys') 52 | (xs' , Var id ) -> modifySubst (extendS (Var id) xs') 53 | (Val (Cons x xs), Val (Cons y ys)) -> unify x y >> unify xs ys 54 | _ -> mzero 55 | 56 | instance Reifiable a => Reifiable (LogicList (LogicVal a)) where 57 | reify lv = do 58 | s <- ask 59 | case walk lv s of 60 | Val Nil -> return $ Val Nil 61 | Val (Cons x xs) -> do 62 | x' <- reify x 63 | xs' <- reify xs 64 | return $ Val (Cons x' xs') 65 | Var id -> reifyVar (Var id) 66 | 67 | append :: Unifiable a 68 | => LogicVal (LogicList a) 69 | -> LogicVal (LogicList a) 70 | -> LogicVal (LogicList a) 71 | -> LogicComp () 72 | append xs ys out = 73 | msum [ do xs ==@ Nil 74 | out === ys 75 | , do x <- var 76 | xs' <- var 77 | res <- var 78 | xs ==@ Cons x xs' 79 | out ==@ Cons x res 80 | append xs' ys res 81 | ] 82 | 83 | testAppend :: LogicComp (LogicVal (LogicList Int)) 84 | testAppend = do x <- var 85 | y <- var 86 | z <- var 87 | x ==@ fromList [1..3] 88 | y ==@ fromList [4..6] 89 | append x y z 90 | return z 91 | 92 | testAppend2 :: LogicComp (LogicVal (LogicList Int)) 93 | testAppend2 = do x <- var 94 | y <- var 95 | z <- var 96 | x ==@ fromList [1..3] 97 | z ==@ fromList [1..6] 98 | append x y z 99 | return y 100 | 101 | testLList :: LogicComp (LogicVal Integer) 102 | testLList = do x <- var 103 | y <- var 104 | fromList [1] @=@ Cons x (Val Nil) 105 | return x 106 | -------------------------------------------------------------------------------- /examples/Infer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | 3 | {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} 4 | 5 | module Language.Logic.Examples.Infer where 6 | 7 | import Language.Logic 8 | import Language.Logic.LogicList 9 | 10 | import Control.Applicative 11 | import Control.Monad 12 | import "mtl" Control.Monad.Reader 13 | import "mtl" Control.Monad.State 14 | 15 | type Variable = String 16 | 17 | data Exp = VarE (LogicVal Variable) 18 | | IntE (LogicVal Int) 19 | | BoolE (LogicVal Bool) 20 | | IsZeroE (LogicVal Exp) 21 | | PredE (LogicVal Exp) 22 | | MultE (LogicVal Exp) (LogicVal Exp) 23 | | IfE (LogicVal Exp) (LogicVal Exp) (LogicVal Exp) 24 | | LamE (LogicVal Variable) (LogicVal Exp) 25 | | AppE (LogicVal Exp) (LogicVal Exp) 26 | deriving (Eq, Show) 27 | 28 | instance Unifiable Exp where 29 | unify x y = do 30 | s <- getSubst 31 | case (walk x s, walk y s) of 32 | (x', y') | x' == y' -> return () 33 | (Var id, y') -> modifySubst (extendS (Var id) y') 34 | (x', Var id) -> modifySubst (extendS (Var id) x') 35 | (Val (VarE x), Val (VarE y)) -> unify x y 36 | (Val (IntE x), Val (IntE y)) -> unify x y 37 | (Val (BoolE x), Val (BoolE y)) -> unify x y 38 | (Val (IsZeroE x), Val (IsZeroE y)) -> unify x y 39 | (Val (PredE x), Val (PredE y)) -> unify x y 40 | (Val (MultE x1 x2), Val (MultE y1 y2)) -> 41 | unify x1 y1 >> unify x2 y2 42 | (Val (IfE xt xc xa), Val (IfE yt yc ya)) -> 43 | unify xt yt >> unify xc yc >> unify xa ya 44 | (Val (LamE x xbody), Val (LamE y ybody)) -> 45 | unify x y >> unify xbody ybody 46 | (Val (AppE xrator xrand), Val (AppE yrator yrand)) -> 47 | unify xrator yrator >> unify xrand yrand 48 | _ -> mzero 49 | 50 | instance Reifiable Exp where 51 | reify lv = do 52 | s <- ask 53 | case walk lv s of 54 | Val (VarE x) -> Val . VarE <$> reify x 55 | Val (IntE x) -> Val . IntE <$> reify x 56 | Val (BoolE x) -> Val . BoolE <$> reify x 57 | Val (IsZeroE x) -> Val . IsZeroE <$> reify x 58 | Val (PredE x) -> Val . PredE <$> reify x 59 | Val (MultE x1 x2) -> Val <$> (MultE <$> reify x1 <*> reify x2) 60 | Val (IfE t c a) -> Val <$> (IfE <$> reify t <*> reify c <*> reify a) 61 | Val (LamE x body) -> Val <$> (LamE <$> reify x <*> reify body) 62 | Val (AppE rator rand) -> Val <$> (AppE <$> reify rator <*> reify rand) 63 | Var id -> reifyVar (Var id) 64 | 65 | data Typ = IntT | BoolT | FunT (LogicVal Typ) (LogicVal Typ) 66 | deriving (Eq, Show) 67 | 68 | instance Unifiable Typ where 69 | unify x y = do 70 | s <- getSubst 71 | case (walk x s, walk y s) of 72 | (x', y') | x' == y' -> return () 73 | (Var id, y') -> modifySubst (extendS (Var id) y') 74 | (x', Var id) -> modifySubst (extendS (Var id) x') 75 | (Val (FunT x1 x2), Val (FunT y1 y2)) -> unify x1 x2 >> unify y1 y2 76 | _ -> mzero 77 | 78 | instance Reifiable Typ where 79 | reify lv = do 80 | s <- ask 81 | case walk lv s of 82 | Val (FunT t1 t2) -> do 83 | t1' <- reify t1 84 | t2' <- reify t2 85 | return $ Val (FunT t1' t2') 86 | Val x -> return $ Val x 87 | Var id -> reifyVar (Var id) 88 | 89 | type TypEnv = LogicList (LogicVal Variable, LogicVal Typ) 90 | 91 | lookupEnv :: LogicVal Variable 92 | -> LogicVal TypEnv 93 | -> LogicVal Typ 94 | -> LogicComp () 95 | lookupEnv x gamma t = 96 | msum [ do gamma' <- var 97 | gamma ==@ Cons (Val (x, t)) gamma' 98 | , do y <- var 99 | yt <- var 100 | gamma' <- var 101 | gamma ==@ Cons (Val (y, yt)) gamma' 102 | lookupEnv x gamma' t 103 | ] 104 | 105 | infer :: LogicVal TypEnv 106 | -> LogicVal Exp 107 | -> LogicVal Typ 108 | -> LogicComp () 109 | infer gamma exp t = 110 | msum [ do x <- var 111 | exp ==@ VarE x 112 | lookupEnv x gamma t 113 | , do n <- var 114 | exp ==@ IntE n 115 | t ==@ IntT 116 | , do b <- var 117 | exp ==@ BoolE b 118 | t ==@ BoolT 119 | , do e <- var 120 | exp ==@ IsZeroE e 121 | t ==@ BoolT 122 | infer gamma e (Val IntT) 123 | , do e <- var 124 | exp ==@ PredE e 125 | t ==@ IntT 126 | infer gamma e (Val IntT) 127 | , do e1 <- var 128 | e2 <- var 129 | exp ==@ MultE e1 e2 130 | t ==@ IntT 131 | infer gamma e1 (Val IntT) 132 | infer gamma e2 (Val IntT) 133 | , do e1 <- var 134 | e2 <- var 135 | e3 <- var 136 | exp ==@ IfE e1 e2 e3 137 | infer gamma e1 (Val BoolT) 138 | infer gamma e2 t 139 | infer gamma e3 t 140 | , do x <- var 141 | body <- var 142 | t1 <- var 143 | t2 <- var 144 | t ==@ FunT t1 t2 145 | exp ==@ LamE x body 146 | infer (Val (Cons (Val (x, t1)) gamma)) body t2 147 | , do rator <- var 148 | rand <- var 149 | t1 <- var 150 | exp ==@ AppE rator rand 151 | infer gamma rator (Val (FunT t1 t)) 152 | infer gamma rand t1 153 | ] 154 | 155 | emptyG :: LogicVal TypEnv 156 | emptyG = (Val Nil) 157 | 158 | varE = Val . VarE . Val 159 | intE = Val . IntE . Val 160 | boolE = Val . BoolE . Val 161 | isZeroE = Val . IsZeroE 162 | predE = Val . PredE 163 | multE x y = Val $ MultE x y 164 | ifE t c a = Val $ IfE t c a 165 | lamE x body = Val $ LamE (Val x) body 166 | appE rator rand = Val $ AppE rator rand 167 | 168 | testInt = do t <- var 169 | infer emptyG (intE 5) t 170 | return t 171 | 172 | testIf = do t <- var 173 | infer emptyG (ifE (boolE True) (intE 2) (intE 3)) t 174 | return t 175 | 176 | testIf2 = do t <- var 177 | infer emptyG (ifE (boolE True) (intE 2) (boolE False)) t 178 | return t 179 | 180 | testLam = do t <- var 181 | infer emptyG (lamE "x" (intE 2)) t 182 | return t 183 | 184 | testLam2 = do t <- var 185 | infer emptyG (lamE "x" (predE (varE "x"))) t 186 | return t -------------------------------------------------------------------------------- /src/Molog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE Rank2Types #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | {-# OPTIONS_GHC -Wall #-} 11 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 12 | module Molog where 13 | 14 | import Control.Applicative 15 | import Control.Monad 16 | import Control.Monad.Logic 17 | import Control.Monad.Ref 18 | import Control.Monad.ST.Persistent 19 | 20 | import Data.Maybe 21 | import Data.STRef.Persistent 22 | 23 | newtype Molog s a = M { unM :: STT s Logic a } 24 | deriving (Functor, Applicative, Alternative, Monad, MonadPlus) 25 | 26 | instance MonadRef (STRef s) (Molog s) where 27 | newRef = M . newRef 28 | readRef = M . readRef 29 | writeRef r x = M $ writeRef r x 30 | 31 | data Term s a = Var !(STRef s (Maybe (Term s a))) 32 | | Val !a 33 | deriving (Eq, Show) 34 | 35 | bindRef :: STRef s (Maybe (Term s a)) -> Term s a -> Molog s () 36 | bindRef r t = writeRef r (Just t) 37 | 38 | semiprune :: Term s a -> Molog s (Term s a) 39 | semiprune t@(Val _) = return t 40 | semiprune t@(Var ref) = go t ref 41 | where go t ref = do 42 | mt <- readRef ref 43 | case mt of 44 | -- fresh var: done 45 | Nothing -> return t 46 | -- one pointer away: done 47 | Just (Val _) -> return t 48 | -- do path compression 49 | Just t'@(Var ref') -> do 50 | result <- go t' ref' 51 | -- overwrite original pointer 52 | bindRef ref result 53 | return result 54 | 55 | fresh :: Molog s (Term s a) 56 | fresh = Var <$> newRef Nothing 57 | 58 | class Unifiable s a where 59 | unify :: Term s a -> Term s a -> Molog s () 60 | unifyWith :: (a -> a -> Molog s ()) -> Term s a -> Term s a -> Molog s () 61 | 62 | default unify :: Eq a => Term s a -> Term s a -> Molog s () 63 | unify x y = unifyWith guardEq x y 64 | where guardEq x y = guard (x == y) 65 | 66 | unifyWith f x y = do 67 | xt <- semiprune x 68 | yt <- semiprune y 69 | case (xt, yt) of 70 | (Var xr, Var yr) | xr == yr -> return () 71 | | otherwise -> do 72 | mxt' <- readRef xr 73 | myt' <- readRef yr 74 | case (mxt', myt') of 75 | (Nothing, Nothing) -> bindRef xr yt 76 | (Nothing, Just _ ) -> bindRef xr yt 77 | (Just _ , Nothing) -> bindRef yr xt 78 | (Just (Val xv), Just (Val yv)) -> f xv yv 79 | _ -> error "impossible: more than 2 pointers after semiprune" 80 | (Var xr, Val yv) -> do 81 | mxt' <- readRef xr 82 | case mxt' of 83 | Nothing -> bindRef xr yt 84 | Just (Val xv) -> f xv yv 85 | _ -> error "impossible: more than 2 pointers after semiprune" 86 | (Val xv, Var yr) -> do 87 | myt' <- readRef yr 88 | case myt' of 89 | Nothing -> bindRef yr xt 90 | Just (Val yv) -> f xv yv 91 | _ -> error "impossible: more than 2 pointers after semiprune" 92 | (Val xv, Val yv) -> f xv yv 93 | 94 | 95 | instance Unifiable s Int 96 | 97 | 98 | instance (Unifiable s a, Unifiable s b) => Unifiable s (Term s a, Term s b) where 99 | unify x y = unifyWith unifyPairs x y 100 | where --unifyPairs :: (Term s a, Term s b) -> (Term s a, Term s b) -> Molog s () 101 | unifyPairs (x1, y1) (x2, y2) = unify x1 x2 >> unify y1 y2 102 | 103 | class Reifiable s a b | a -> b where 104 | reify :: a -> Molog s (Maybe b) 105 | 106 | instance Reifiable s a b => Reifiable s (Term s a) b where 107 | reify (Val v) = reify v 108 | reify (Var ref) = do 109 | mt <- readRef ref 110 | case mt of 111 | Just (Val v) -> reify v -- return . maybe Nothing (Just . Val) =<< reify v 112 | Just (Var ref') -> do 113 | mt' <- readRef ref' 114 | case mt' of 115 | Just (Val v) -> reify v 116 | _ -> return Nothing 117 | _ -> return Nothing 118 | 119 | instance Reifiable s Int Int where 120 | reify = return . Just 121 | 122 | instance (Reifiable s a c, Reifiable s b d) => Reifiable s (a, b) (c, d) where 123 | reify (x, y) = do 124 | mx' <- reify x 125 | my' <- reify y 126 | case (mx', my') of 127 | (Just x', Just y') -> return (Just (x', y')) 128 | _ -> return Nothing 129 | 130 | reify' :: Reifiable s a b => a -> Molog s b 131 | reify' x = do mx' <- reify x 132 | case mx' of 133 | Nothing -> mzero 134 | Just x' -> return x' 135 | 136 | runMolog :: (forall s . Molog s a) -> [a] 137 | runMolog c = observeAll (runSTT (unM c)) 138 | 139 | {- 140 | 141 | class Eq a => Unifiable a where 142 | unify :: LogicVal a 143 | -> LogicVal a 144 | -> LogicComp () 145 | unify x y = do 146 | s <- getSubst 147 | case (walk x s, walk y s) of 148 | (x' , y' ) | x' == y' -> return () 149 | (Var id, y' ) -> modifySubst (extendS (Var id) y') 150 | (x' , Var id) -> modifySubst (extendS (Var id) x') 151 | _ -> mzero 152 | 153 | instance Unifiable Bool 154 | instance Unifiable Int 155 | instance Unifiable Integer 156 | instance Unifiable Char 157 | 158 | instance Unifiable a => Unifiable [a] where 159 | unify xs ys = do 160 | s <- getSubst 161 | case (walk xs s, walk ys s) of 162 | (xs' , ys' ) | xs' == ys' -> return () 163 | (Var id, ys' ) -> modifySubst (extendS (Var id) ys') 164 | (xs' , Var id) -> modifySubst (extendS (Var id) xs') 165 | _ -> mzero 166 | 167 | instance (Unifiable a) => Unifiable [LogicVal a] where 168 | unify xs ys = do 169 | s <- getSubst 170 | case (walk xs s, walk ys s) of 171 | (xs' , ys' ) | xs' == ys' -> return () 172 | (Var id , ys' ) -> modifySubst (extendS (Var id) ys') 173 | (xs' , Var id ) -> modifySubst (extendS (Var id) xs') 174 | ((Val xs), (Val ys)) -> zipWithM_' unify xs ys 175 | where zipWithM_' f [] [] = return () 176 | zipWithM_' f (x:xs) (y:ys) = f x y >> zipWithM_' f xs ys 177 | zipWithM_' f _ _ = mzero 178 | 179 | instance (Unifiable a, Unifiable b) => Unifiable (a, b) where 180 | unify x y = do 181 | s <- getSubst 182 | case (walk x s, walk y s) of 183 | (x', y') | x' == y' -> return () 184 | (Var id, y') -> modifySubst (extendS (Var id) y') 185 | (x', Var id) -> modifySubst (extendS (Var id) x') 186 | _ -> mzero 187 | 188 | instance (Unifiable a, Unifiable b) => Unifiable (LogicVal a, LogicVal b) where 189 | unify x y = do 190 | s <- getSubst 191 | case (walk x s, walk y s) of 192 | (x', y') | x' == y' -> return () 193 | (Var id, y') -> modifySubst (extendS (Var id) y') 194 | (x', Var id) -> modifySubst (extendS (Var id) x') 195 | (Val (xf, xs), Val (yf, ys)) -> unify xf yf >> unify xs ys 196 | 197 | type LogicState = (VarId, Subst) 198 | 199 | emptyState :: LogicState 200 | emptyState = (0, emptyS) 201 | 202 | type LogicComp a = StateT LogicState Logic a 203 | 204 | var :: LogicComp (LogicVal a) 205 | var = do id <- fst <$> get 206 | modify (\(id, s) -> (id+1, s)) 207 | return $ Var id 208 | 209 | (===) :: Unifiable a => LogicVal a -> LogicVal a -> LogicComp () 210 | (===) = unify 211 | 212 | (==@) :: (Unifiable a) => LogicVal a -> a -> LogicComp () 213 | x ==@ y = x === Val y 214 | 215 | (@==) :: (Unifiable a) => a -> LogicVal a -> LogicComp () 216 | (@==) = flip (==@) 217 | 218 | (@=@) :: (Unifiable a) => a -> a -> LogicComp () 219 | x @=@ y = Val x === Val y 220 | 221 | testComp :: LogicComp (LogicVal Int) 222 | testComp = do x <- var 223 | y <- var 224 | x === y 225 | y ==@ 5 226 | return y 227 | 228 | run :: Reifiable a => LogicComp (LogicVal a) -> [LogicVal a] 229 | run c = map reifyOne results 230 | where results = observeAll $ runStateT c emptyState 231 | reifyOne (lv, (_, s)) = 232 | runReader (evalStateT (unRC $ reify lv) emptyRS) s 233 | 234 | testComp2 :: LogicComp (LogicVal Int) 235 | testComp2 = do x <- var 236 | (x ==@ 5) `mplus` (x ==@ 6) 237 | return x 238 | 239 | testComp3 :: LogicComp (LogicVal String) 240 | testComp3 = do x <- var 241 | x ==@ "foo" 242 | -- x ==@ 5 -- program rejected with this uncommented! 243 | return x 244 | 245 | testList :: LogicComp (LogicVal [LogicVal Int]) 246 | testList = do x <- var 247 | y <- var 248 | x ==@ 5 249 | y ==@ [Val 1, x, Val 8] 250 | return y 251 | 252 | testList2 :: LogicComp (LogicVal [LogicVal Int]) 253 | testList2 = do x <- var 254 | y <- var 255 | y ==@ [Val 1, x, Val 8] 256 | return y 257 | 258 | testList3 :: LogicComp (LogicVal [LogicVal Int]) 259 | testList3 = do x <- var 260 | y <- var 261 | z <- var 262 | x ==@ [Val 1, Val 2, z] 263 | y === x 264 | return y 265 | 266 | type ReifySubst = Map VarId VarId 267 | 268 | emptyRS = Map.empty 269 | 270 | newtype ReifyComp a = RC { unRC :: StateT ReifySubst (Reader Subst) a } 271 | deriving (Functor, Applicative, Monad, MonadReader Subst, MonadState ReifySubst) 272 | 273 | class Reifiable a where 274 | reify :: LogicVal a -> (ReifyComp (LogicVal a)) 275 | reify lv = do 276 | s <- ask 277 | case walk lv s of 278 | Val x -> return $ Val x 279 | Var id -> reifyVar (Var id) 280 | 281 | instance Reifiable Bool 282 | instance Reifiable Char 283 | instance Reifiable Int 284 | instance Reifiable Integer 285 | instance Reifiable [a] 286 | 287 | instance Reifiable a => Reifiable [LogicVal a] where 288 | reify lv = do 289 | s <- ask 290 | case walk lv s of 291 | Val xs -> Val <$> mapM reify xs 292 | Var id -> reifyVar (Var id) 293 | 294 | instance Reifiable a => Reifiable (LogicVal a) 295 | 296 | reifyVar :: LogicVal a -> ReifyComp (LogicVal a) 297 | reifyVar (Var id) = do 298 | rs <- get 299 | case Map.lookup id rs of 300 | Just rname -> return $ Var rname 301 | Nothing -> do 302 | let rname = fromIntegral $ Map.size rs 303 | modify (Map.insert id rname) 304 | return $ Var rname 305 | reifyVar _ = error "reifyVar is only for fresh variables" 306 | 307 | --instance Reifiable a => Reifiable [a] where 308 | -- reify lv s = undefined 309 | 310 | -- instance Eq a => Reifiable (LogicVal a) where 311 | -} 312 | --------------------------------------------------------------------------------