Implement new functor parsing

ma.cabal

@@ -22,6 +22,7 @@ library
                      , Data.Functors.FixedProduct
                      , Data.Functors.MonoidValued
                      , Data.Functors
+                     , Data.FunctorsNew
                      , Data.Sort
                      , Data.RefinablePartition
                      , Data.Vector.Unboxed.Mutable.Utils
@@ -33,6 +34,7 @@ library
                      , Text.Parser.Lexer
                      , Text.Parser.Types
                      , Text.Parser.Functor
+                     , Text.Parser.FunctorNew
                      , Parser
                      , Algorithm
   default-language:    Haskell2010

src/Data/Functors.hs

@@ -22,8 +22,3 @@ registeredFunctors =
   where
     f :: RefinementInterface a => FunctorParser a -> SomeFunctorParser
     f = SomeFunctorParser
-
--- new interface
-
-type AllFunctors
-   = Union '[ Powerset', FixedProduct', MonoidValued' Int, MonoidValued' Double]

src/Data/Functors/Powerset.hs

+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -12,11 +13,17 @@ import qualified Data.Yaml as Yaml
 import           Data.RefinementInterface
 import qualified Data.MorphismEncoding as Encoding
 import           Text.Parser.Functor
+import           Text.Parser.FunctorNew
 import qualified Text.Parser.Lexer as L
 
 -- New interface
 
 data Powerset' a = Powerset' a
+  deriving (Functor)
+
+instance ParseFunctor Powerset' where
+  precedence = 5
+  parseFunctor = Prefix' (L.symbol "P" >> pure Powerset')
 
 -- Old interface
 

src/Data/FunctorsNew.hs

+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
+
+module Data.FunctorsNew where
+
+import           Data.RefinementInterface
+import           Data.Functors.Powerset (powerset, Powerset')
+import           Data.Functors.FixedProduct (FixedProduct', fixedproduct)
+import           Data.Functors.MonoidValued (MonoidValued', intValued, realValued)
+import           Data.OpenUnion
+
+type AllFunctors
+   = '[ Powerset', FixedProduct', MonoidValued' Int, MonoidValued' Double]
+
+data Fix f = Fix (f (Fix f))
+
+newtype NestedFunctors = NestedFunctors (Fix (Union AllFunctors))

src/Data/OpenUnion.hs

+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -41,9 +43,13 @@ module Data.OpenUnion
   , inj
   , prj
   , Member
+  -- * Helpers for working with type lists
+  , All
+  , Sublist
   ) where
 
 import Unsafe.Coerce
+import Data.Kind
 
 -- | An open sum type.
 --
@@ -103,3 +109,13 @@ unsafePrj :: Word -> Union ls a -> Maybe (f a)
 unsafePrj i1 (In i2 x)
   | i1 == i2 = Just (unsafeCoerce x)
   | otherwise = Nothing
+
+
+type family All (c :: k -> Constraint) (xs :: [k]) :: Constraint where
+  All _ '[]    = ()
+  All c (x:xs) = (c x, All c xs)
+
+type family Sublist (xs :: [k]) (ys :: [k]) :: Constraint where
+  Sublist '[] _    = ()
+  Sublist (x:xs) ys = (Member x ys, Sublist xs ys)
+

src/Text/Parser/Functor.hs

@@ -9,6 +9,9 @@ module Text.Parser.Functor
   )
   where
 
+import           Data.List
+import           Data.Function (on)
+
 import           Text.Megaparsec
 import qualified Text.Megaparsec.Expr as Expr
 

src/Text/Parser/FunctorNew.hs

+{-# LANGUAGE UndecidableSuperClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Text.Parser.FunctorNew where
+
+import           Data.List
+import           Data.Function (on)
+
+import           Text.Megaparsec
+import qualified Text.Megaparsec.Expr as Expr
+
+import           Text.Parser.Types
+import           Text.Parser.Lexer
+import           Data.RefinementInterface
+import           Data.OpenUnion
+
+data FunctorParser' a = Prefix' (Parser a) | Postfix' (Parser a)
+  deriving (Functor)
+
+data Fix f = Fix (f (Fix f))
+
+type NestedFunctors fs = (Fix (Union fs))
+
+class Functor f => ParseFunctor f where
+  precedence :: Int
+  parseFunctor :: FunctorParser' (a -> f a)
+
+toOp :: forall f fs.
+        (Member f fs, ParseFunctor f)
+     => (Int, Expr.Operator Parser (NestedFunctors fs))
+toOp = case parseFunctor @f of
+  Prefix' p -> (precedence @f, Expr.Prefix (fmap ((Fix . inj @f @fs) .) p))
+  Postfix' p -> (precedence @f, Expr.Postfix (fmap ((Fix . inj @f @fs) .) p))
+
+class ToOpTable fs (lst :: [* -> *]) where
+  toOpTable :: [(Int, Expr.Operator Parser (NestedFunctors fs))]
+
+instance ToOpTable fs '[] where
+  toOpTable = []
+
+instance (ParseFunctor x, Member x fs, ToOpTable fs xs) => ToOpTable fs (x ': xs) where
+  toOpTable = toOp @x @fs : toOpTable @fs @xs
+
+data Hole a = Hole
+  deriving (Functor)
+
+parseHole :: Member Hole fs => Parser (NestedFunctors fs)
+parseHole = symbol "X" >> return (Fix (inj Hole))
+
+functorsParser' :: forall (fs :: [* -> *]).
+                   ToOpTable (Hole ': fs) fs
+                => Parser (NestedFunctors (Hole ': fs))
+functorsParser' =
+  let
+    sortedOps = sortBy (compare `on` fst) (toOpTable @(Hole ': fs) @fs)
+    opTable = map (map snd) (groupBy ((==) `on` fst) sortedOps)
+    termParser = parseHole <|> parens functorsParser'
+  in
+    try spaceConsumer *> Expr.makeExprParser termParser opTable