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
, 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
......
......@@ -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]
{-# 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
......
{-# 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 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)
......@@ -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
......
{-# 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