-
Notifications
You must be signed in to change notification settings - Fork 1
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
1 parent
bf82375
commit 8f83dad
Showing
5 changed files
with
191 additions
and
167 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -1,166 +1,4 @@ | ||
{-# LANGUAGE ScopedTypeVariables #-} | ||
{-# LANGUAGE GADTs #-} | ||
{-# LANGUAGE StandaloneDeriving #-} | ||
{-# LANGUAGE DeriveFunctor #-} | ||
{-# LANGUAGE TypeFamilies #-} | ||
{-# LANGUAGE InstanceSigs #-} | ||
{-# LANGUAGE RankNTypes #-} | ||
{-# LANGUAGE UndecidableInstances #-} | ||
{-# LANGUAGE DerivingVia #-} | ||
{-# LANGUAGE TypeOperators #-} | ||
{-# LANGUAGE StandaloneKindSignatures #-} | ||
module Gigaparsec (module Gigaparsec.Core, module Gigaparsec.Syntax) where | ||
|
||
module Gigaparsec ( Parser, reify, nt, parse, decode, char ) where | ||
|
||
import qualified Data.Set as Set | ||
import Data.Set (Set) | ||
import qualified Data.Map as Map | ||
import Data.Map (Map) | ||
import Control.Applicative (Alternative) | ||
import Unsafe.Coerce ( unsafeCoerce ) | ||
import Data.Functor.Compose ( Compose(Compose) ) | ||
import Data.Reify ( reifyGraph, MuRef(..), Graph(Graph), Unique ) | ||
import GHC.Exts (Any) | ||
import System.IO.Unsafe (unsafePerformIO) | ||
import Data.Maybe (fromMaybe) | ||
import Data.Kind | ||
|
||
data ActionF a f = AscendF a | MatchF Char (ActionF a f) | forall b. DescendF f (ActionF (b -> a) f) | ||
instance Show f => Show (ActionF a f) where | ||
show AscendF{} = "AscendF" | ||
show (MatchF c xs) = "(MatchF " ++ show c ++ " " ++ show xs ++ ")" | ||
show (DescendF x xs) = "(DescendF " ++ show x ++ " " ++ show xs ++ ")" | ||
data ListF a f = Nil | Cons (a f) (ListF a f) deriving Show | ||
|
||
data Action m a where | ||
Match :: Char -> Action m () | ||
Descend :: m a -> Action m a | ||
|
||
type Alt :: (Type -> Type) -> ((Type -> Type) -> Type -> Type) -> Type -> Type | ||
newtype Alt m f a = Alt [AltF m f a] | ||
deriving (Functor, Applicative, Alternative) via Compose [] (AltF m f) | ||
type AltF :: (Type -> Type) -> ((Type -> Type) -> Type -> Type) -> Type -> Type | ||
data AltF m f a = Pure a | forall b. Ap (f m b) (AltF m f (b -> a)) | ||
deriving instance Functor (AltF m f) | ||
instance Applicative (AltF m f) where | ||
pure = Pure | ||
Pure f <*> q = fmap f q | ||
Ap x p <*> q = Ap x (flip <$> p <*> q) | ||
|
||
newtype Parser a = Parser (Alt Parser Action a) | ||
deriving (Functor, Applicative, Alternative) via Alt Parser Action | ||
|
||
instance MuRef (Parser a) where | ||
type DeRef (Parser a) = ListF (ActionF Any) | ||
mapDeRef :: forall f u. Applicative f => (forall b. (MuRef b, DeRef (Parser a) ~ DeRef b) => b -> f u) -> Parser a -> f (DeRef (Parser a) u) | ||
mapDeRef _ (Parser (Alt [])) = pure Nil | ||
mapDeRef f (Parser (Alt (x:xs))) = Cons <$> helper x <*> mapDeRef f (Parser (Alt xs)) where | ||
helper :: forall b. AltF Parser Action b -> f (ActionF Any u) | ||
helper (Pure a) = pure (AscendF (unsafeCoerce a)) | ||
helper (Ap (Match c) r) = MatchF c <$> helper r | ||
helper (Ap (Descend y) r) = DescendF <$> f y <*> unsafeCoerce (helper r) | ||
|
||
newtype Name n a = Name n deriving Show | ||
|
||
reify :: Parser a -> (G Unique, Name Unique a) | ||
reify acts = (G (Map.fromList [ (u, f x') | (u, x') <- xs ]), Name x) where | ||
(Graph xs x) = unsafePerformIO $ reifyGraph acts | ||
|
||
f :: ListF (ActionF Any) Unique -> [AltF (Name Unique) Action Any] | ||
f Nil = [] | ||
f (Cons h t) = g h ++ f t | ||
|
||
g :: forall a. ActionF a Unique -> [AltF (Name Unique) Action a] | ||
g (AscendF r) = [Pure r] | ||
g (MatchF c r) = Ap (Match c) . fmap const <$> g r | ||
g (DescendF u r) = Ap (Descend (Name u)) <$> g r | ||
|
||
newtype G n = G (Map n [AltF (Name n) Action Any]) | ||
|
||
lookupG :: forall n a. Ord n => G n -> Name n a -> [AltF (Name n) Action a] | ||
lookupG (G m) (Name n) = unsafeCoerce (m Map.! n) | ||
|
||
nt :: Parser a -> Parser a | ||
nt xs = Parser $ Alt [Ap (Descend xs) (pure id)] | ||
|
||
compareName :: Ord n => Name n a -> Name n b -> Ordering | ||
compareName (Name x) (Name y) = compare x y | ||
|
||
compareSlot :: Ord n => Slot n a -> Slot n b -> Ordering | ||
compareSlot (Slot x1 x2 x3 _ _) (Slot y1 y2 y3 _ _) = compareName x1 y1 <> compare x2 y2 <> compare x3 y3 | ||
|
||
compareDescriptor :: Ord n => Descriptor n a -> Descriptor n b -> Ordering | ||
compareDescriptor (Descriptor x1 x2 x3 _) (Descriptor y1 y2 y3 _) = compareSlot x1 y1 <> compare x2 y2 <> compare x3 y3 | ||
|
||
data Deps n a b where | ||
Self :: Deps n a a | ||
Dep :: Name n b -> Int -> Int -> Deps n a c -> Deps n a (b -> c) | ||
deriving instance Show n => Show (Deps n a b) | ||
|
||
data Slot n a = forall b. Slot !(Name n a) !Int !Int (Deps n a b) (AltF (Name n) Action b) | ||
data Descriptor n a = Descriptor (Slot n a) !Int !Int String | ||
data SomeDescriptor n = forall a. SomeDescriptor (Descriptor n a) | ||
instance Ord n => Eq (SomeDescriptor n) where | ||
SomeDescriptor x == SomeDescriptor y = compareDescriptor x y == EQ | ||
instance Ord n => Ord (SomeDescriptor n) where | ||
compare (SomeDescriptor x) (SomeDescriptor y) = compareDescriptor x y | ||
|
||
initialDescriptor :: Name n a -> String -> Int -> AltF (Name n) Action a -> SomeDescriptor n | ||
initialDescriptor n xs i act = SomeDescriptor (Descriptor (Slot n i 0 Self act) 0 0 xs) | ||
|
||
newtype WaitForAscend n = WA (Map (n, Int) [Int -> String -> SomeDescriptor n]) | ||
newtype WaitForDescend n = WD (Map (n, Int) [(Int, String)]) | ||
|
||
emptyWA :: WaitForAscend n | ||
emptyWA = WA Map.empty | ||
|
||
lookupWA :: forall a n. Ord n => WaitForAscend n -> Name n a -> Int -> [Int -> String -> SomeDescriptor n] | ||
lookupWA (WA m) (Name n) k = fromMaybe [] (m Map.!? (n, k)) | ||
|
||
insertWA :: Ord n => Name n a -> Int -> (Int -> String -> SomeDescriptor n) -> WaitForAscend n -> WaitForAscend n | ||
insertWA (Name n) k f (WA m) = WA (Map.insertWith (++) (n, k) [f] m) | ||
|
||
emptyWD :: WaitForDescend n | ||
emptyWD = WD Map.empty | ||
|
||
lookupWD :: forall a n. Ord n => WaitForDescend n -> Name n a -> Int -> [(Int, String)] | ||
lookupWD (WD m) (Name n) k = fromMaybe [] (m Map.!? (n, k)) | ||
|
||
insertWD :: Ord n => Name n a -> Int -> (Int, String) -> WaitForDescend n -> WaitForDescend n | ||
insertWD (Name n) k x (WD m) = WD (Map.insertWith (++) (n, k) [x] m) | ||
|
||
parse :: forall n a. Ord n => (G n, Name n a) -> String -> Set (SomeDescriptor n) | ||
parse (g, z) xs0 = go Set.empty emptyWA emptyWD (zipWith (initialDescriptor z xs0) [0..] (lookupG g z)) where | ||
go :: Set (SomeDescriptor n) -> WaitForAscend n -> WaitForDescend n -> [SomeDescriptor n] -> Set (SomeDescriptor n) | ||
go u wa wd (d : rs) | d `Set.member` u = go u wa wd rs | ||
go u wa wd (d@(SomeDescriptor (Descriptor (Slot x a i ds (Ap (Match c) r)) l k xs)) : rs) | ||
| c' : xs' <- xs, c == c' = go (Set.insert d u) wa wd (SomeDescriptor (Descriptor (Slot x a (i + 1) ds (($ ()) <$> r)) l (k + 1) xs') : rs) | ||
| otherwise = go u wa wd rs | ||
go u wa wd (d@(SomeDescriptor (Descriptor (Slot x a i ds (Ap (Descend n) next)) l k xs)) : rs) | ||
= go (Set.insert d u) (insertWA n k (\r xs' -> SomeDescriptor (Descriptor (Slot x a (i + 1) (Dep n k r ds) next) l r xs')) wa) wd $ concat | ||
[ [ SomeDescriptor (Descriptor (Slot n a' 0 Self acts) k k xs) | (a', acts) <- zip [0..] (lookupG g n) ] | ||
, [ SomeDescriptor (Descriptor (Slot x a (i + 1) (Dep n k r ds) next) l r xs') | (r, xs') <- lookupWD wd n k ] | ||
, rs | ||
] | ||
go u wa wd (d@(SomeDescriptor (Descriptor (Slot x _ _ _ (Pure _)) k r xs)) : rs) | ||
= go (Set.insert d u) wa (insertWD x k (r, xs) wd) | ||
([ f r xs | f <- lookupWA wa x k ] ++ rs) | ||
go u _ _ [] = u | ||
|
||
decode :: forall n a. (Show n, Ord n) => Set (SomeDescriptor n) -> Name n a -> Int -> Int -> [a] | ||
decode ds0 = lookupM where | ||
m :: Map (n, Int, Int) [Any] | ||
m = Map.fromListWith (++) | ||
[ ((x, l, r), map unsafeCoerce (go ds [a])) | ||
| SomeDescriptor (Descriptor (Slot (Name x) _ _ ds (Pure a)) l r _) <- Set.toList ds0 | ||
] | ||
|
||
lookupM :: forall c. Name n c -> Int -> Int -> [c] | ||
lookupM (Name n) l r = maybe [] (map unsafeCoerce) (m Map.!? (n, l, r)) | ||
|
||
go :: forall b c. Deps n b c -> [c] -> [b] | ||
go Self x = x | ||
go (Dep n l r xs) fs = go xs $ fs <*> lookupM n l r | ||
|
||
char :: Char -> Parser Char | ||
char c = Parser (Alt [Ap (Match c) (pure (const c))]) | ||
import Gigaparsec.Core | ||
import Gigaparsec.Syntax |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,42 @@ | ||
{-# LANGUAGE DerivingVia #-} | ||
module Gigaparsec.Common where | ||
import Data.Kind | ||
import Data.Functor.Compose | ||
import Control.Applicative | ||
import Data.Map (Map) | ||
import GHC.Exts (Any) | ||
import qualified Data.Map as Map | ||
import Unsafe.Coerce | ||
|
||
data ActionF a f = AscendF a | MatchF Char (ActionF (() -> a) f) | forall b. DescendF f (ActionF (b -> a) f) | ||
instance Show f => Show (ActionF a f) where | ||
show AscendF{} = "AscendF" | ||
show (MatchF c xs) = "(MatchF " ++ show c ++ " " ++ show xs ++ ")" | ||
show (DescendF x xs) = "(DescendF " ++ show x ++ " " ++ show xs ++ ")" | ||
data ListF a f = Nil | Cons (a f) (ListF a f) deriving Show | ||
|
||
data Action m a where | ||
Match :: Char -> Action m () | ||
Descend :: m a -> Action m a | ||
|
||
-- Free alternative, see https://hackage.haskell.org/package/free-5.2/docs/Control-Alternative-Free.html | ||
-- But this one is higher-order. | ||
|
||
type Alt :: (Type -> Type) -> ((Type -> Type) -> Type -> Type) -> Type -> Type | ||
newtype Alt m f a = Alt { getAlts :: [AltF m f a] } | ||
deriving (Functor, Applicative, Alternative) via Compose [] (AltF m f) | ||
type AltF :: (Type -> Type) -> ((Type -> Type) -> Type -> Type) -> Type -> Type | ||
data AltF m f a = Pure a | forall b. Ap (f m b) (AltF m f (b -> a)) | ||
deriving instance Functor (AltF m f) | ||
instance Applicative (AltF m f) where | ||
pure = Pure | ||
Pure f <*> q = fmap f q | ||
Ap x p <*> q = Ap x (flip <$> p <*> q) | ||
|
||
type Name :: Type -> Type -> Type | ||
newtype Name n a = Name n deriving Show | ||
|
||
newtype G n = G (Map n [AltF (Name n) Action Any]) | ||
|
||
lookupG :: forall n a. Ord n => G n -> Name n a -> [AltF (Name n) Action a] | ||
lookupG (G m) (Name n) = unsafeCoerce (m Map.! n) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,99 @@ | ||
|
||
{-# LANGUAGE ScopedTypeVariables #-} | ||
{-# LANGUAGE GADTs #-} | ||
{-# LANGUAGE StandaloneDeriving #-} | ||
{-# LANGUAGE TypeFamilies #-} | ||
{-# LANGUAGE RankNTypes #-} | ||
{-# LANGUAGE UndecidableInstances #-} | ||
{-# LANGUAGE DerivingVia #-} | ||
|
||
module Gigaparsec.Core ( parse, decode ) where | ||
|
||
import qualified Data.Set as Set | ||
import Data.Set (Set) | ||
import qualified Data.Map as Map | ||
import Data.Map (Map) | ||
import Unsafe.Coerce ( unsafeCoerce ) | ||
import GHC.Exts (Any) | ||
import Data.Maybe (fromMaybe) | ||
|
||
import Gigaparsec.Common | ||
|
||
compareName :: Ord n => Name n a -> Name n b -> Ordering | ||
compareName (Name x) (Name y) = compare x y | ||
|
||
compareSlot :: Ord n => Slot n a -> Slot n b -> Ordering | ||
compareSlot (Slot x1 x2 x3 _ _) (Slot y1 y2 y3 _ _) = compareName x1 y1 <> compare x2 y2 <> compare x3 y3 | ||
|
||
compareDescriptor :: Ord n => Descriptor n a -> Descriptor n b -> Ordering | ||
compareDescriptor (Descriptor x1 x2 x3 _) (Descriptor y1 y2 y3 _) = compareSlot x1 y1 <> compare x2 y2 <> compare x3 y3 | ||
|
||
data Deps n a b where | ||
Self :: Deps n a a | ||
Dep :: Name n b -> Int -> Int -> Deps n a c -> Deps n a (b -> c) | ||
deriving instance Show n => Show (Deps n a b) | ||
|
||
data Slot n a = forall b. Slot !(Name n a) !Int !Int (Deps n a b) (AltF (Name n) Action b) | ||
data Descriptor n a = Descriptor (Slot n a) !Int !Int String | ||
data SomeDescriptor n = forall a. SomeDescriptor (Descriptor n a) | ||
instance Ord n => Eq (SomeDescriptor n) where | ||
SomeDescriptor x == SomeDescriptor y = compareDescriptor x y == EQ | ||
instance Ord n => Ord (SomeDescriptor n) where | ||
compare (SomeDescriptor x) (SomeDescriptor y) = compareDescriptor x y | ||
|
||
initialDescriptor :: Name n a -> String -> Int -> AltF (Name n) Action a -> SomeDescriptor n | ||
initialDescriptor n xs i act = SomeDescriptor (Descriptor (Slot n i 0 Self act) 0 0 xs) | ||
|
||
newtype WaitForAscend n = WA (Map (n, Int) [Int -> String -> SomeDescriptor n]) | ||
newtype WaitForDescend n = WD (Map (n, Int) [(Int, String)]) | ||
|
||
emptyWA :: WaitForAscend n | ||
emptyWA = WA Map.empty | ||
|
||
lookupWA :: forall a n. Ord n => WaitForAscend n -> Name n a -> Int -> [Int -> String -> SomeDescriptor n] | ||
lookupWA (WA m) (Name n) k = fromMaybe [] (m Map.!? (n, k)) | ||
|
||
insertWA :: Ord n => Name n a -> Int -> (Int -> String -> SomeDescriptor n) -> WaitForAscend n -> WaitForAscend n | ||
insertWA (Name n) k f (WA m) = WA (Map.insertWith (++) (n, k) [f] m) | ||
|
||
emptyWD :: WaitForDescend n | ||
emptyWD = WD Map.empty | ||
|
||
lookupWD :: forall a n. Ord n => WaitForDescend n -> Name n a -> Int -> [(Int, String)] | ||
lookupWD (WD m) (Name n) k = fromMaybe [] (m Map.!? (n, k)) | ||
|
||
insertWD :: Ord n => Name n a -> Int -> (Int, String) -> WaitForDescend n -> WaitForDescend n | ||
insertWD (Name n) k x (WD m) = WD (Map.insertWith (++) (n, k) [x] m) | ||
|
||
parse :: forall n a. Ord n => (G n, Name n a) -> String -> Set (SomeDescriptor n) | ||
parse (g, z) xs0 = go Set.empty emptyWA emptyWD (zipWith (initialDescriptor z xs0) [0..] (lookupG g z)) where | ||
go :: Set (SomeDescriptor n) -> WaitForAscend n -> WaitForDescend n -> [SomeDescriptor n] -> Set (SomeDescriptor n) | ||
go u wa wd (d : rs) | d `Set.member` u = go u wa wd rs | ||
go u wa wd (d@(SomeDescriptor (Descriptor (Slot x a i ds (Ap (Match c) r)) l k xs)) : rs) | ||
| c' : xs' <- xs, c == c' = go (Set.insert d u) wa wd (SomeDescriptor (Descriptor (Slot x a (i + 1) ds (($ ()) <$> r)) l (k + 1) xs') : rs) | ||
| otherwise = go u wa wd rs | ||
go u wa wd (d@(SomeDescriptor (Descriptor (Slot x a i ds (Ap (Descend n) next)) l k xs)) : rs) | ||
= go (Set.insert d u) (insertWA n k (\r xs' -> SomeDescriptor (Descriptor (Slot x a (i + 1) (Dep n k r ds) next) l r xs')) wa) wd $ concat | ||
[ [ SomeDescriptor (Descriptor (Slot n a' 0 Self acts) k k xs) | (a', acts) <- zip [0..] (lookupG g n) ] | ||
, [ SomeDescriptor (Descriptor (Slot x a (i + 1) (Dep n k r ds) next) l r xs') | (r, xs') <- lookupWD wd n k ] | ||
, rs | ||
] | ||
go u wa wd (d@(SomeDescriptor (Descriptor (Slot x _ _ _ (Pure _)) k r xs)) : rs) | ||
= go (Set.insert d u) wa (insertWD x k (r, xs) wd) | ||
([ f r xs | f <- lookupWA wa x k ] ++ rs) | ||
go u _ _ [] = u | ||
|
||
decode :: forall n a. (Show n, Ord n) => Set (SomeDescriptor n) -> Name n a -> Int -> Int -> [a] | ||
decode ds0 = lookupM where | ||
m :: Map (n, Int, Int) [Any] | ||
m = Map.fromListWith (++) | ||
[ ((x, l, r), map unsafeCoerce (go ds [a])) | ||
| SomeDescriptor (Descriptor (Slot (Name x) _ _ ds (Pure a)) l r _) <- Set.toList ds0 | ||
] | ||
|
||
lookupM :: forall c. Name n c -> Int -> Int -> [c] | ||
lookupM (Name n) l r = maybe [] (map unsafeCoerce) (m Map.!? (n, l, r)) | ||
|
||
go :: forall b c. Deps n b c -> [c] -> [b] | ||
go Self x = x | ||
go (Dep n l r xs) fs = go xs $ fs <*> lookupM n l r |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,45 @@ | ||
{-# LANGUAGE DerivingVia #-} | ||
{-# LANGUAGE TypeFamilies #-} | ||
{-# LANGUAGE UndecidableInstances #-} | ||
|
||
module Gigaparsec.Syntax where | ||
|
||
import Gigaparsec.Common | ||
import GHC.Exts (Any) | ||
import Control.Applicative | ||
import Data.Reify | ||
import qualified Data.Map as Map | ||
import Unsafe.Coerce (unsafeCoerce) | ||
import System.IO.Unsafe (unsafePerformIO) | ||
|
||
newtype Parser a = Parser (Alt Parser Action a) | ||
deriving (Functor, Applicative, Alternative) via Alt Parser Action | ||
|
||
instance MuRef (Parser a) where | ||
type DeRef (Parser a) = ListF (ActionF Any) | ||
mapDeRef :: forall f u. Applicative f => (forall b. (MuRef b, DeRef (Parser a) ~ DeRef b) => b -> f u) -> Parser a -> f (DeRef (Parser a) u) | ||
mapDeRef _ (Parser (Alt [])) = pure Nil | ||
mapDeRef f (Parser (Alt (x:xs))) = Cons <$> helper x <*> mapDeRef f (Parser (Alt xs)) where | ||
helper :: forall b. AltF Parser Action b -> f (ActionF Any u) | ||
helper (Pure a) = pure (AscendF (unsafeCoerce a)) | ||
helper (Ap (Match c) r) = MatchF c <$> unsafeCoerce (helper r) | ||
helper (Ap (Descend y) r) = DescendF <$> f y <*> unsafeCoerce (helper r) | ||
|
||
reify :: Parser a -> (G Unique, Name Unique a) | ||
reify acts = (G (Map.fromList [ (u, f x') | (u, x') <- xs ]), Name x) where | ||
(Graph xs x) = unsafePerformIO $ reifyGraph acts | ||
|
||
f :: ListF (ActionF Any) Unique -> [AltF (Name Unique) Action Any] | ||
f Nil = [] | ||
f (Cons h t) = g h ++ f t | ||
|
||
g :: forall a. ActionF a Unique -> [AltF (Name Unique) Action a] | ||
g (AscendF r) = [Pure r] | ||
g (MatchF c r) = Ap (Match c) <$> g r | ||
g (DescendF u r) = Ap (Descend (Name u)) <$> g r | ||
|
||
nt :: Parser a -> Parser a | ||
nt xs = Parser $ Alt [Ap (Descend xs) (pure id)] | ||
|
||
char :: Char -> Parser Char | ||
char c = Parser (Alt [Ap (Match c) (pure (const c))]) |