src/Gyehoek/Scheme/Expand.hs

@@ -17,6 +17,7 @@ import qualified Data.List.NonEmpty as NE
 import Data.Monoid (Ap(Ap, getAp))
 import Gyehoek.Sexp.Grammar.Base ((:-)(..))
 import Control.Lens.Extras (is)
+import Control.Applicative (Alternative(..))
 
 
 data Scope = MkScope
@@ -43,7 +44,10 @@ data Trans = MkTrans
   }
   deriving (Show, Generic)
 
-data Rule = MkRule Pat Tem
+data Rule = MkRule
+  { rhs :: Pat
+  , lhs :: Tem
+  }
   deriving (Show, Generic)
 
 data Pat
@@ -196,25 +200,50 @@ instance S.DatumIso Tem where
 -- Just
 -- ...
 match :: Pat -> Datum -> Maybe (HashMap Name Datum)
+match p = getAp . match' p
   
-match PatWildcard _ = Just mempty
+match' :: Pat -> Datum -> Ap Maybe (HashMap Name Datum)
 
-match (PatVar x) e = Just $ H.singleton x e
+match' PatWildcard _ = pure mempty
 
-match (PatList ps Nothing Nothing) (List es) = matches ps es
+match' (PatVar x) e = pure $ H.singleton x e
 
-match (PatList ps Nothing (Just p)) (DotList es e) =
+match' (PatList ps Nothing Nothing) (List es) = matches ps es
+
+match' (PatList ps (Just []) Nothing) (List es) = do
+  let (ps',p) = ps ^?! _Snoc
+  (r,rest) <- fold $ alignWith f ps' es
+  rest' <- rest
+    & fmap (fmap (fmap (:[])) . match' p)
+    & foldr (liftA2 $ H.unionWith (<>)) mempty
+    & fmap (fmap List)
+  pure $ r <> rest'
+  where
+    f (These a b) = (,[]) <$> match' a b
+    f (This a) = empty
+    f (That b) = pure (mempty,[b])
+
+match' (PatList ps Nothing (Just p)) (DotList es e) =
   matches (p:|ps) (NE.cons e es)
 
-match _ _ = _
+match' _ _ = _
+
+matchPrefix
+  :: (Semialign f, Foldable f)
+  => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum, List Datum)
+matchPrefix ps es = fold $ alignWith f ps es
+  where
+    f (These a b) = (,[]) <$> match' a b
+    f (This a) = empty
+    f (That b) = pure (mempty,[b])
 
 matches
   :: (Semialign f, Foldable f)
-  => f Pat -> f Datum -> Maybe (HashMap Name Datum)
+  => f Pat -> f Datum -> Ap Maybe (HashMap Name Datum)
-matches ps es = getAp . foldMap Ap $ alignWith f ps es
+matches ps es = fold $ alignWith matchThese ps es
-  where
+
-    f (These a b) = match a b
+matchThese (These a b) = match' a b
-    f _ = Nothing
+matchThese _ = empty