Commit e6ca3a62 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel 🐢

Specialize parser monad in parseMorphismPoint

Leaving the types entierly abstract is surely more pleasing, but also
the biggest source of slowness.
parent f20aef98
......@@ -14,9 +14,9 @@ import Text.Megaparsec.Char
import Control.Monad.State.Strict
import MA.Coalgebra.Parser
import MA.Coalgebra.Parser.Internal
import MA.Coalgebra.RefinementTypes
import MA.Functors.MonoidValued
import MA.Parser.Types
benchmarks :: Benchmark
benchmarks = bgroup "MA.Functors.BenchMonoid"
......@@ -35,15 +35,15 @@ benchIntValued = bgroup "IntValued" $
benchParseMorphPoint :: forall f. (ParseMorphism f, Functor f, NFData (Label f), NFData (H1 f)) => String -> f () -> Text -> Benchmark
benchParseMorphPoint !name !f !input =
bench name (nf (parse (evalStateT parser 0) "") input)
bench name (nf (parse (evalStateT parser initState) "") input)
where
parser :: StateT Int Parser (H1 f, Vector (Int, Label f))
parser :: MorphParser () () (H1 f, Vector (Int, Label f))
parser = parseMorphismPoint (fmap (const newInt) f)
newInt :: StateT Int Parser Int
newInt :: MorphParser () () Int
newInt = do
_ <- char 'x'
i <- get
put (i+1)
return i
s <- get
put s { _nextState = _nextState s + 1 }
return (_nextState s)
......@@ -50,6 +50,7 @@ library
, MA.FunctorExpression.Sorts
, MA.FunctorExpression.Desorting
, MA.Coalgebra.Parser
, MA.Coalgebra.Parser.Internal
, MA.Coalgebra.RefinementTypes
, MA.PartitionPrinter
default-extensions: GADTs
......
......@@ -8,6 +8,7 @@ module MA.Coalgebra.Parser
, morphismsParser
, ParseMorphism(..)
, SymbolTable(..)
, MorphParser
) where
import Data.Void (Void)
......@@ -24,35 +25,19 @@ import qualified Data.Vector as V
import Data.Vector (Vector)
import Control.DeepSeq (NFData)
import MA.FunctorExpression.Type
import MA.FunctorExpression.Sorts (Sort)
import MA.Parser.Lexer
import MA.Parser.Types
import Data.MorphismEncoding (Encoding, State)
import qualified Data.MorphismEncoding as Encoding
import MA.Coalgebra.Parser.Internal
import MA.Coalgebra.RefinementTypes
data Symbol = Defined | Undefined
deriving (Eq)
data ParserState l h1 = ParserState
{ _graph :: M.HashMap State (Sort, (h1, Vector (State, l)))
, _symbolTable :: M.HashMap Text (State, Symbol)
, _nextState :: Int
}
makeLenses ''ParserState
initState :: ParserState l h1
initState = ParserState
{ _graph = M.empty
, _symbolTable = M.empty
, _nextState = 0
}
import MA.FunctorExpression.Sorts (Sort)
import MA.FunctorExpression.Type
import MA.Parser.Lexer
import MA.Parser.Types
type MorphParser l h1 = StateT (ParserState l h1) Parser
class ParseMorphism f where
parseMorphismPoint :: (Eq x, Ord x, MonadParser m) => f (m x) -> m (H1 f, Vector (x, Label f))
parseMorphismPoint :: (Ord x) => f (MorphParser l h1 x) -> MorphParser l h1 (H1 f, Vector (x, Label f))
newState :: MorphParser l h1 State
newState = nextState <<%= succ
......
{-# LANGUAGE TemplateHaskell #-}
module MA.Coalgebra.Parser.Internal
( ParserState(..)
, graph
, symbolTable
, nextState
, Symbol(..)
, initState
) where
import qualified Data.HashMap.Strict as M
import Data.Text (Text)
import Data.Vector (Vector)
import Lens.Micro.Platform
import Data.MorphismEncoding (State)
import MA.FunctorExpression.Sorts (Sort)
data Symbol = Defined | Undefined
deriving (Eq)
data ParserState l h1 = ParserState
{ _graph :: M.HashMap State (Sort, (h1, Vector (State, l)))
, _symbolTable :: M.HashMap Text (State, Symbol)
, _nextState :: Int
}
makeLenses ''ParserState
initState :: ParserState l h1
initState = ParserState
{ _graph = M.empty
, _symbolTable = M.empty
, _nextState = 0
}
......@@ -10,6 +10,7 @@ import MA.FunctorExpression.Type
import MA.FunctorExpression.Sorts
import MA.RefinementInterface
import MA.Coalgebra.RefinementTypes
import MA.Functors.SomeFunctor
data Desorted f a = Desorted (FunctorExpression f Sort) a
deriving (Functor, Foldable, Traversable, Show)
......@@ -23,6 +24,7 @@ type instance Weight (Desorted f) = (Sort, Weight f)
type instance H3 (Desorted f) = (Sort, H3 f)
instance RefinementInterface f => RefinementInterface (Desorted f) where
{-# SPECIALIZE instance RefinementInterface (Desorted SomeFunctor) #-}
init (sort, h1) labels = (sort, init @f h1 (filterBySort sort labels))
update labels (sort, w) =
......
......@@ -68,8 +68,8 @@ parseMorphismPointHelper inner weightParser = do
where
edge = (,) <$> inner <*> (L.colon *> (L.signed weightParser))
{-# INLINE parseMorphismPointHelper #-}
{-# SPECIALIZE parseMorphismPointHelper :: MonadParser m => m Int -> m Int -> m (Int, Vector (Int, Int)) #-}
{-# SPECIALIZE parseMorphismPointHelper :: MonadParser m => m Int -> m Double -> m (Double, Vector (Int, Double)) #-}
{-# SPECIALIZE parseMorphismPointHelper :: MorphParser l h1 Int -> MorphParser l h1 Int -> MorphParser l h1 (Int, Vector (Int, Int)) #-}
{-# SPECIALIZE parseMorphismPointHelper :: MorphParser l h1 Int -> MorphParser l h1 Double -> MorphParser l h1 (Double, Vector (Int, Double)) #-}
instance ParseMorphism (MonoidValued Int) where
parseMorphismPoint (IntValued inner) = parseMorphismPointHelper inner L.decimal
......
......@@ -104,7 +104,7 @@ instance RefinementInterface SomeFunctor where
Just HRefl -> Just l
instance ParseMorphism SomeFunctor where
parseMorphismPoint (SomeFunctor (f :: tf (m x))) = do
parseMorphismPoint (SomeFunctor (f :: tf (MorphParser l h1 x))) = do
fmap convert (parseMorphismPoint f)
where
......
Markdown is supported
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