Commit 22fed3e6 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel
Browse files

Implement new functor parsing

parent 635e0f13
...@@ -22,6 +22,7 @@ library ...@@ -22,6 +22,7 @@ library
, Data.Functors.FixedProduct , Data.Functors.FixedProduct
, Data.Functors.MonoidValued , Data.Functors.MonoidValued
, Data.Functors , Data.Functors
, Data.FunctorsNew
, Data.Sort , Data.Sort
, Data.RefinablePartition , Data.RefinablePartition
, Data.Vector.Unboxed.Mutable.Utils , Data.Vector.Unboxed.Mutable.Utils
...@@ -33,6 +34,7 @@ library ...@@ -33,6 +34,7 @@ library
, Text.Parser.Lexer , Text.Parser.Lexer
, Text.Parser.Types , Text.Parser.Types
, Text.Parser.Functor , Text.Parser.Functor
, Text.Parser.FunctorNew
, Parser , Parser
, Algorithm , Algorithm
default-language: Haskell2010 default-language: Haskell2010
......
...@@ -22,8 +22,3 @@ registeredFunctors = ...@@ -22,8 +22,3 @@ registeredFunctors =
where where
f :: RefinementInterface a => FunctorParser a -> SomeFunctorParser f :: RefinementInterface a => FunctorParser a -> SomeFunctorParser
f = SomeFunctorParser f = SomeFunctorParser
-- new interface
type AllFunctors
= Union '[ Powerset', FixedProduct', MonoidValued' Int, MonoidValued' Double]
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
...@@ -12,11 +13,17 @@ import qualified Data.Yaml as Yaml ...@@ -12,11 +13,17 @@ import qualified Data.Yaml as Yaml
import Data.RefinementInterface import Data.RefinementInterface
import qualified Data.MorphismEncoding as Encoding import qualified Data.MorphismEncoding as Encoding
import Text.Parser.Functor import Text.Parser.Functor
import Text.Parser.FunctorNew
import qualified Text.Parser.Lexer as L import qualified Text.Parser.Lexer as L
-- New interface -- New interface
data Powerset' a = Powerset' a data Powerset' a = Powerset' a
deriving (Functor)
instance ParseFunctor Powerset' where
precedence = 5
parseFunctor = Prefix' (L.symbol "P" >> pure Powerset')
-- Old interface -- Old interface
......
{-# 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))
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
...@@ -41,9 +43,13 @@ module Data.OpenUnion ...@@ -41,9 +43,13 @@ module Data.OpenUnion
, inj , inj
, prj , prj
, Member , Member
-- * Helpers for working with type lists
, All
, Sublist
) where ) where
import Unsafe.Coerce import Unsafe.Coerce
import Data.Kind
-- | An open sum type. -- | An open sum type.
-- --
...@@ -103,3 +109,13 @@ unsafePrj :: Word -> Union ls a -> Maybe (f a) ...@@ -103,3 +109,13 @@ unsafePrj :: Word -> Union ls a -> Maybe (f a)
unsafePrj i1 (In i2 x) unsafePrj i1 (In i2 x)
| i1 == i2 = Just (unsafeCoerce x) | i1 == i2 = Just (unsafeCoerce x)
| otherwise = Nothing | 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)
...@@ -9,6 +9,9 @@ module Text.Parser.Functor ...@@ -9,6 +9,9 @@ module Text.Parser.Functor
) )
where where
import Data.List
import Data.Function (on)
import Text.Megaparsec import Text.Megaparsec
import qualified Text.Megaparsec.Expr as Expr import qualified Text.Megaparsec.Expr as Expr
......
{-# 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
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment