module NLP.GenI.GeniVal.Internal where
import Control.Arrow (first, (***))
import Control.Monad (liftM)
import Data.Binary
import Data.List
import Data.Maybe (fromMaybe, isNothing, isJust)
import Data.Generics (Data)
import Data.Typeable (Typeable)
import qualified Data.Map as Map
import Data.Text ( Text )
import qualified Data.Text as T
import Control.DeepSeq
import Data.FullList ( FullList, fromFL, Listable(..), sortNub )
import NLP.GenI.General (geniBug, quoteText, isGeniIdentLetter)
import NLP.GenI.GeniShow
import NLP.GenI.Pretty
data GeniVal = GeniVal { gLabel :: Maybe Text
, gConstraints :: Maybe (FullList Text)
}
deriving (Eq,Ord, Data, Typeable)
mkGConst :: FullList Text
-> GeniVal
mkGConst cs_ = GeniVal Nothing (Just cs)
where
cs = sortNub cs_
mkGConstNone :: Text -> GeniVal
mkGConstNone x = mkGConst (x !: [])
mkGVar :: Text -> Maybe (FullList Text) -> GeniVal
mkGVar x mxs = GeniVal (Just x) (sortNub `fmap` mxs)
mkGVarNone :: Text -> GeniVal
mkGVarNone x = mkGVar x Nothing
mkGAnon :: GeniVal
mkGAnon = GeniVal Nothing Nothing
instance Pretty GeniVal where
pretty = geniShowText
instance GeniShow GeniVal where
geniShowText gv =
case gv of
GeniVal Nothing Nothing -> showLabel "_"
GeniVal Nothing (Just cs) -> showConstraints cs
GeniVal (Just l) Nothing -> showLabel l
GeniVal (Just l) (Just cs) ->
showLabel l `T.append` "/" `T.append` showConstraints cs
where
showLabel l = '?' `T.cons` l
showConstraints = T.intercalate "|" . map maybeQuote . fromFL
maybeQuote x | T.null x = quoteText ""
| "-" `T.isPrefixOf` x = quoteText x
| "+" `T.isPrefixOf` x = quoteText x
| T.any naughty x = quoteText x
| otherwise = x
naughty x = not (isGeniIdentLetter x) || x `elem` "_?/"
isConst :: GeniVal -> Bool
isConst = isNothing . gLabel
singletonVal :: GeniVal -> Maybe Text
singletonVal v =
case fmap fromFL (gConstraints v) of
Just [o] -> Just o
_ -> Nothing
isVar :: GeniVal -> Bool
isVar = isJust . gConstraints
isAnon :: GeniVal -> Bool
isAnon (GeniVal Nothing Nothing) = True
isAnon _ = False
type Subst = Map.Map Text GeniVal
prettySubst :: Subst -> Text
prettySubst =
T.unwords . map sho . Map.toList
where
sho (v,s) = v `T.append` "<-" `T.append` pretty s
unify :: Monad m => [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst)
unify = unifyHelper unifyOne
allSubsume :: Monad m => [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst)
allSubsume = unifyHelper subsumeOne
unifyHelper :: Monad m
=> (GeniVal -> GeniVal -> UnificationResult)
-> [GeniVal]
-> [GeniVal]
-> m ([GeniVal], Subst)
unifyHelper f ll1 ll2 = repropagate `liftM` helper ll1 ll2
where
repropagate (xs, sub) = (replace sub xs, sub)
helper [] l2 = return (l2, Map.empty)
helper l1 [] = return (l1, Map.empty)
helper (h1:t1) (h2:t2) =
case f h1 h2 of
Failure -> fail . T.unpack . T.unwords $
[ "unification failure between"
, pretty h1, "and"
, pretty h2
]
SuccessRep v g -> prepend `liftM` helper t1b t2b
where
s = (v,g)
t1b = replaceOne s t1
t2b = replaceOne s t2
prepend = (g:) *** prependToSubst s
SuccessRep2 v1 v2 g -> prepend `liftM` helper t1b t2b
where
s1 = (v1,g)
s2 = (v2,g)
t1b = replaceOne s2 . replaceOne s1 $ t1
t2b = replaceOne s2 . replaceOne s1 $ t2
prepend = (g:) *** (prependToSubst s1 . prependToSubst s2)
SuccessSans g -> first (g:) `liftM` helper t1 t2
appendSubst :: Subst -> Subst -> Subst
appendSubst sm1 sm2 = Map.foldrWithKey (curry prependToSubst) sm2 sm1
prependToSubst :: (Text,GeniVal) -> Subst -> Subst
prependToSubst (v, gr@(GeniVal (Just r) _)) sm =
case Map.lookup v sm of
Just v2 -> geniBug . unlines $
[ "prependToSubst: GenI just tried to prepend the substitution"
, " " ++ prettyStr (mkGVar v Nothing) ++ " -> " ++ prettyStr gr
, "to one where where "
, " " ++ prettyStr (mkGVar v Nothing) ++ " -> " ++ prettyStr v2
, "is slated to occur afterwards."
, ""
, "This could mean that either"
, " (a) the core unification algorithm is broken"
, " (b) we failed to propagate a value somewhere or"
, " (c) we are attempting unification without renaming."
]
Nothing -> Map.insert v gr2 sm
where gr2 = fromMaybe gr $ Map.lookup r sm
prependToSubst (v, gr) sm = Map.insert v gr sm
data UnificationResult = SuccessSans GeniVal
| SuccessRep Text GeniVal
| SuccessRep2 Text Text GeniVal
| Failure
unifyOne :: GeniVal -> GeniVal -> UnificationResult
unifyOne (GeniVal Nothing Nothing) g = SuccessSans g
unifyOne g (GeniVal Nothing Nothing) = SuccessSans g
unifyOne g1 g2 =
maybe Failure constrSuccess (intersectConstraints gc1 gc2)
where
gc1 = gConstraints g1
gc2 = gConstraints g2
constrSuccess cs =
case (gLabel g1, gLabel g2) of
(Nothing, Nothing) -> SuccessSans (GeniVal Nothing cs)
(Nothing, Just v) -> SuccessRep v (GeniVal Nothing cs)
(Just v, Nothing) -> SuccessRep v (GeniVal Nothing cs)
(Just v1, Just v2) -> bothLabeled cs v1 v2
bothLabeled cs v1 v2
| v1 == v2 && gc1 /= gc2 = geniBug constraintBug
| v1 == v2 = SuccessSans g1
| gc1 == gc2 = successSameConstraints cs v1 v2
| otherwise = successDiffConstraints cs v1 v2
successSameConstraints cs v1 v2 =
SuccessRep (min v1 v2) $ GeniVal (Just (max v1 v2)) cs
successDiffConstraints cs v1 v2 =
SuccessRep2 (min v1 v2) (max v1 v2) $
GeniVal (Just (max v1 v2 `T.append` "-g")) cs
constraintBug = unwords
[ "I just tried to unify variable with itself,"
, "but it has mismatching constraints:"
, prettyStr g1, "vs."
, prettyStr g2
]
intersectConstraints :: Eq a => Maybe (FullList a) -> Maybe (FullList a) -> Maybe (Maybe (FullList a))
intersectConstraints Nothing cs = Just cs
intersectConstraints cs Nothing = Just cs
intersectConstraints (Just v1) (Just v2) =
case fromFL v1 `intersect` fromFL v2 of
[] -> Nothing
(x:xs) -> Just (Just (x !: xs))
subsumeOne :: GeniVal -> GeniVal -> UnificationResult
subsumeOne g1@(GeniVal _ (Just cs1)) g2@ (GeniVal _ (Just cs2)) =
if fromFL cs1 `subset` fromFL cs2 then unifyOne g1 g2 else Failure
where
subset x y = all (`elem` y) x
subsumeOne (GeniVal _ (Just _)) (GeniVal _ Nothing) = Failure
subsumeOne g1@(GeniVal _ Nothing) g2 = unifyOne g1 g2
replace :: DescendGeniVal a => Subst -> a -> a
replace m | Map.null m = id
replace m = descendGeniVal (replaceMapG m)
replaceOne :: DescendGeniVal a => (Text, GeniVal) -> a -> a
replaceOne = descendGeniVal . replaceOneG
replaceList :: DescendGeniVal a => [(Text,GeniVal)] -> a -> a
replaceList = replace . foldl' update Map.empty
where
update m (s1,s2) = Map.insert s1 s2 $ Map.map (replaceOne (s1,s2)) m
replaceMapG :: Subst -> GeniVal -> GeniVal
replaceMapG m v@(GeniVal (Just v_) _) = Map.findWithDefault v v_ m
replaceMapG _ v = v
replaceOneG :: (Text, GeniVal) -> GeniVal -> GeniVal
replaceOneG (s1, s2) (GeniVal (Just v_) _) | v_ == s1 = s2
replaceOneG _ v = v
type CollectedVar = (Text, Maybe (FullList Text))
class Collectable a where
collect :: a -> Map.Map CollectedVar Int -> Map.Map CollectedVar Int
instance Collectable a => Collectable (Maybe a) where
collect Nothing s = s
collect (Just x) s = collect x s
instance (Collectable a => Collectable [a]) where
collect l s = foldr collect s l
instance Collectable GeniVal where
collect (GeniVal (Just v) cs) s = Map.insertWith' (+) (v,cs) 1 s
collect (GeniVal Nothing _) s = s
class Idable a where
idOf :: a -> Integer
anonymiseSingletons :: (Collectable a, DescendGeniVal a) => a -> a
anonymiseSingletons x =
replace subst x
where
subst = Map.map (const mkGAnon) . Map.filter (== 1)
. Map.fromListWith (+) . map (first fst) . Map.toList
$ collect x Map.empty
finaliseVarsById :: (Collectable a, DescendGeniVal a, Idable a) => a -> a
finaliseVarsById x = finaliseVars ('-' `T.cons` (T.pack . show $ idOf x)) x
finaliseVars :: (Collectable a, DescendGeniVal a) => Text -> a -> a
finaliseVars suffix x =
replace subst (anonymiseSingletons x)
where
subst :: Subst
subst = Map.mapWithKey convert vars
vars = Map.fromListWithKey isect $ Map.keys (collect x Map.empty)
isect k xi yi =
fromMaybe (Just (impossibleC k)) $ intersectConstraints xi yi
convert v = GeniVal (Just (v `T.append` suffix))
impossibleC v = ("ERROR_impossible_constraints_" `T.append` v `T.append` suffix)
!: []
crushOne :: [GeniVal] -> Maybe GeniVal
crushOne [] = Nothing
crushOne [gs] = Just gs
crushOne gs =
if any isNothing gcs
then Nothing
else case concat [ fromFL c | Just c <- gcs ] of
[] -> Nothing
(c:cs) -> Just (mkGConst (c !: cs))
where
gcs = map gConstraints gs
crushList :: [[GeniVal]] -> Maybe [GeniVal]
crushList = mapM crushOne
class DescendGeniVal a where
descendGeniVal :: (GeniVal -> GeniVal) -> a -> a
instance DescendGeniVal GeniVal where
descendGeniVal f = f
instance (Functor f, DescendGeniVal a) => DescendGeniVal (f a) where
descendGeniVal = fmap . descendGeniVal
instance NFData GeniVal where
rnf (GeniVal x y) = rnf x `seq` rnf y
instance Binary GeniVal where
put (GeniVal a b) = put a >> put b
get = get >>= \a -> get >>= \b -> return (GeniVal a b)