102 lines
3.7 KiB
Plaintext
102 lines
3.7 KiB
Plaintext
module Language.Bergamot.Syntax where
|
|
|
|
import Prelude (Unit, ($), (<<<), unit, (/=), const, flip, (+))
|
|
|
|
import Control.Plus (class Plus, empty)
|
|
import Control.Monad (class Monad)
|
|
import Control.Monad.State.Trans (StateT, runStateT)
|
|
import Control.Monad.State.Class (gets, modify)
|
|
import Control.Apply (class Apply, apply)
|
|
import Control.Alt (class Alt, alt)
|
|
import Control.Alternative (class Alternative)
|
|
import Control.Applicative (class Applicative, pure)
|
|
import Control.Bind (class Bind, bind, (>>=))
|
|
import Control.MonadPlus (class MonadPlus)
|
|
import Control.Monad.Logic.Class (class MonadLogic, msplit, interleave)
|
|
import Control.Monad.Unify.Class (class MonadUnify, class Unifiable, class UnificationVariable, Stream(..), squash, alongside, ComparisonAction(..))
|
|
import Control.Monad.Unify.Trans (UnifyT(..), runUnifyT)
|
|
import Control.Monad.Logic.Trans (SFKT(..), runSFKT)
|
|
import Data.List (List(..), (:))
|
|
import Data.Functor (class Functor, (<$>), map)
|
|
import Data.Eq (class Eq)
|
|
import Data.Ord (class Ord)
|
|
import Data.Traversable (class Traversable, sequence, traverse)
|
|
import Data.Foldable (class Foldable, foldr, foldl, foldMap, any)
|
|
import Data.Monoid ((<>), mempty)
|
|
import Data.Map (Map, lookup, insert)
|
|
import Data.Map as Map
|
|
import Data.Set (Set, singleton, union)
|
|
import Data.Tuple (Tuple(..), fst)
|
|
import Data.Tuple.Nested ((/\))
|
|
import Data.Lazy (Lazy, defer, force)
|
|
import Data.Newtype (class Newtype, un, over2)
|
|
import Data.Maybe (Maybe(..), fromMaybe, isJust)
|
|
import Data.Bifunctor (rmap)
|
|
|
|
data Expr v
|
|
= Var v
|
|
| Atom String (List (Expr v))
|
|
|
|
derive instance Eq v => Eq (Expr v)
|
|
derive instance Functor Expr
|
|
|
|
instance Foldable Expr where
|
|
foldr f b (Var x) = f x b
|
|
foldr f b (Atom _ xs) = foldr (\x b' -> foldr f b' x) b xs
|
|
|
|
foldl f b (Var x) = f b x
|
|
foldl f b (Atom _ xs) = foldl (foldl f) b xs
|
|
|
|
foldMap f (Var x) = f x
|
|
foldMap f (Atom _ xs) = foldl (<>) mempty (foldMap f <$> xs)
|
|
|
|
instance Traversable Expr where
|
|
sequence (Var f) = Var <$> f
|
|
sequence (Atom name fs) = Atom name <$> sequence (sequence <$> fs)
|
|
|
|
traverse f e = sequence (f <$> e)
|
|
|
|
newtype IntVar = MkIntVar Int
|
|
|
|
derive instance Eq IntVar
|
|
derive instance Ord IntVar
|
|
|
|
instance UnificationVariable IntVar where
|
|
variables = mkVarList 0
|
|
where mkVarList n = StreamCons (MkIntVar n) $ defer $ \_ -> mkVarList (n+1)
|
|
|
|
instance UnificationVariable k => Unifiable k Expr where
|
|
variable = Var
|
|
squash (Var f) = f
|
|
squash (Atom name args) = Atom name $ squash <$> args
|
|
alongside (Var k1) (Var k2) = Var (Merge k1 k2)
|
|
alongside (Var k) f = Var (Store k f)
|
|
alongside f (Var k) = Var (Store k f)
|
|
alongside (Atom n1 _) (Atom n2 _) | n1 /= n2 = Var Fail
|
|
alongside (Atom n1 args1) (Atom _ args2) = Atom n1 $ combine args1 args2
|
|
where
|
|
combine Nil Nil = Nil
|
|
combine (_:_) Nil = (Var Fail) : Nil
|
|
combine Nil (_:_) = (Var Fail) : Nil
|
|
combine (x:xs) (y:ys) = alongside x y : combine xs ys
|
|
|
|
newtype Unifier a = MkUnifier (UnifyT IntVar Expr (SFKT Maybe) a)
|
|
|
|
derive instance Newtype (Unifier a) _
|
|
derive newtype instance Functor Unifier
|
|
derive newtype instance Apply Unifier
|
|
derive newtype instance Applicative Unifier
|
|
derive newtype instance Alternative Unifier
|
|
derive newtype instance Bind Unifier
|
|
derive newtype instance Monad Unifier
|
|
derive newtype instance MonadPlus Unifier
|
|
derive newtype instance MonadUnify IntVar Expr Unifier
|
|
|
|
-- >:(
|
|
instance MonadLogic Unifier where
|
|
msplit m = MkUnifier $ MkUnifyT $ map (map (rmap (MkUnifier <<< MkUnifyT))) $ msplit $ un MkUnifyT $ un MkUnifier m
|
|
interleave = over2 MkUnifier (over2 MkUnifyT interleave)
|
|
|
|
runUnifier :: forall a. Unifier a -> Maybe a
|
|
runUnifier m = runSFKT (runUnifyT $ un MkUnifier m) (const <<< Just) Nothing
|