Commit 071aaed6 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel
Browse files

Random stuff that improves performance

[skip ci]
parent 1b23b6b3
...@@ -44,12 +44,14 @@ library ...@@ -44,12 +44,14 @@ library
, MA.Algorithm.Types , MA.Algorithm.Types
, MA.Algorithm.Initialize , MA.Algorithm.Initialize
, MA.Algorithm.Split , MA.Algorithm.Split
, MA.Algorithm.Internal
, MA.FunctorExpression.Type , MA.FunctorExpression.Type
, MA.FunctorExpression.Parser , MA.FunctorExpression.Parser
, MA.FunctorExpression.Pretty , MA.FunctorExpression.Pretty
, MA.FunctorExpression.Sorts , MA.FunctorExpression.Sorts
, MA.FunctorExpression.Desorting , MA.FunctorExpression.Desorting
, MA.Coalgebra.Parser , MA.Coalgebra.Parser
, MA.Coalgebra.Parser.Class
, MA.Coalgebra.Parser.Internal , MA.Coalgebra.Parser.Internal
, MA.Coalgebra.RefinementTypes , MA.Coalgebra.RefinementTypes
, MA.PartitionPrinter , MA.PartitionPrinter
......
...@@ -29,6 +29,7 @@ module Data.RefinablePartition ...@@ -29,6 +29,7 @@ module Data.RefinablePartition
, groupBy , groupBy
-- * Conversion -- * Conversion
, freeze , freeze
, unsafeStatesOfBlock
) where ) where
import Control.Monad (forM_, when, foldM) import Control.Monad (forM_, when, foldM)
...@@ -41,7 +42,7 @@ import qualified Data.Vector.Algorithms.Heap as VM ...@@ -41,7 +42,7 @@ import qualified Data.Vector.Algorithms.Heap as VM
import Data.Vector.Mutable (MVector) import Data.Vector.Mutable (MVector)
import qualified Data.Vector.Mutable as VM import qualified Data.Vector.Mutable as VM
import qualified Data.Vector.Unboxed.Mutable as VU import qualified Data.Vector.Unboxed.Mutable as VU
import qualified Data.Vector.Unboxed as VUU import qualified Data.Vector.Unboxed as VU (convert, freeze, unsafeFreeze, Vector)
import Lens.Micro import Lens.Micro
import Lens.Micro.TH import Lens.Micro.TH
...@@ -227,25 +228,36 @@ isMarked partition s = do ...@@ -227,25 +228,36 @@ isMarked partition s = do
-- | Return the marked states of a block. -- | Return the marked states of a block.
-- --
-- Runtime O(n) for n == number of states in this block -- Runtime O(n) for n == number of states in this block
markedStates :: RefinablePartition s -> Block -> ST s (V.Vector State) markedStates :: RefinablePartition s -> Block -> ST s (VU.Vector State)
markedStates partition b = do markedStates partition b = do
block <- getBlock partition b block <- getBlock partition b
let len = block^.unmarkedOffset - block^.startOffset let len = block^.unmarkedOffset - block^.startOffset
V.convert <$> VU.freeze (VU.slice (block^.startOffset) len (partition^.statesByBlock))
VUU.freeze (VU.slice (block^.startOffset) len (partition^.statesByBlock))
-- | Return a vector of all states in a given block. -- | Return a vector of all states in a given block.
-- --
-- Runtime: O(n) for n == number of states in this block -- Runtime: O(n) for n == number of states in this block
statesOfBlock :: RefinablePartition s -> Block -> ST s (V.Vector State) statesOfBlock :: RefinablePartition s -> Block -> ST s (VU.Vector State)
statesOfBlock partition b = do statesOfBlock partition b = do
block <- getBlock partition b block <- getBlock partition b
len <- blockSize partition b len <- blockSize partition b
let slice = VU.slice (block^.startOffset) len (partition^.statesByBlock) let slice = VU.slice (block^.startOffset) len (partition^.statesByBlock)
V.convert <$> VUU.freeze slice VU.freeze slice
-- | Return a vector of all states in a given block.
--
-- Runtime: O(n) for n == number of states in this block
unsafeStatesOfBlock :: RefinablePartition s -> Block -> ST s (VU.Vector State)
unsafeStatesOfBlock partition b = do
block <- getBlock partition b
len <- blockSize partition b
let slice = VU.slice (block^.startOffset) len (partition^.statesByBlock)
VU.unsafeFreeze slice
-- | Split a block into two new blocks for its marked and unmarked states. -- | Split a block into two new blocks for its marked and unmarked states.
-- --
...@@ -404,19 +416,24 @@ freeze partition = do ...@@ -404,19 +416,24 @@ freeze partition = do
-- helpers -- helpers
getBlock :: RefinablePartition s -> Block -> ST s BlockRepr getBlock :: RefinablePartition s -> Block -> ST s BlockRepr
getBlock !partition (Block b) = VM.unsafeRead (_blocks partition) b getBlock !partition (Block b) = VM.unsafeRead (_blocks partition) b
{-# INLINE getBlock #-}
setBlock :: RefinablePartition s -> Block -> (BlockRepr -> BlockRepr) -> ST s () setBlock :: RefinablePartition s -> Block -> (BlockRepr -> BlockRepr) -> ST s ()
setBlock partition (Block b) setter = VM.unsafeModify (_blocks partition) setter b setBlock partition (Block b) setter = VM.unsafeModify (_blocks partition) setter b
{-# INLINE setBlock #-}
getState :: RefinablePartition s -> State -> ST s StateRepr getState :: RefinablePartition s -> State -> ST s StateRepr
getState partition s = VM.unsafeRead (partition^.states) s getState partition s = VM.unsafeRead (partition^.states) s
{-# INLINE getState #-}
setState :: RefinablePartition s -> State -> (StateRepr -> StateRepr) -> ST s () setState :: RefinablePartition s -> State -> (StateRepr -> StateRepr) -> ST s ()
setState partition s setter = VM.modify (partition^.states) setter s setState partition s setter = VM.modify (partition^.states) setter s
{-# INLINE setState #-}
setStateAt :: RefinablePartition s -> Int -> (StateRepr -> StateRepr) -> ST s () setStateAt :: RefinablePartition s -> Int -> (StateRepr -> StateRepr) -> ST s ()
setStateAt partition loc setter = VU.read (partition^.statesByBlock) loc >>= \state -> setStateAt partition loc setter = VU.read (partition^.statesByBlock) loc >>= \state ->
setState partition state setter setState partition state setter
{-# INLINE setStateAt #-}
newBlock :: RefinablePartition s -> Int -> Int -> ST s Block newBlock :: RefinablePartition s -> Int -> Int -> ST s Block
newBlock partition beginning end = do newBlock partition beginning end = do
......
...@@ -9,6 +9,7 @@ module Data.Vector.Unboxed.Mutable.Utils ...@@ -9,6 +9,7 @@ module Data.Vector.Unboxed.Mutable.Utils
) where ) where
import Control.Monad (foldM) import Control.Monad (foldM)
import qualified Control.Monad.ST.Strict
import Control.Monad.Primitive import Control.Monad.Primitive
import qualified Data.Vector.Unboxed.Mutable as VU import qualified Data.Vector.Unboxed.Mutable as VU
...@@ -33,8 +34,21 @@ partition :: (VU.Unbox a, PrimMonad m) ...@@ -33,8 +34,21 @@ partition :: (VU.Unbox a, PrimMonad m)
-> Int -- ^ The beginning of the region to partition (inclusive) -> Int -- ^ The beginning of the region to partition (inclusive)
-> Int -- ^ The end of the region to partition (exclusive) -> Int -- ^ The end of the region to partition (exclusive)
-> m Int -> m Int
partition vec predicate = partitionM vec (return . predicate) partition vec predicate = go
{-# INLINE partition #-} where
go lower upper
| lower >= upper = return lower
| otherwise = do
l <- VU.read vec lower
r <- VU.read vec (upper-1)
let predL = predicate l
let predR = predicate r
if predL then go (lower+1) upper
else if not predR then go lower (upper-1)
else VU.swap vec lower (upper-1) >> go (lower+1) upper
{-# SPECIALIZE INLINE partition :: VU.MVector s Int -> (Int -> Bool) -> Int -> Int -> Control.Monad.ST.Strict.ST s Int #-}
-- | 'partition' with monadic predicate -- | 'partition' with monadic predicate
partitionM :: (VU.Unbox a, PrimMonad m) partitionM :: (VU.Unbox a, PrimMonad m)
......
{-# LANGUAGE BangPatterns #-}
module Data.Vector.Utils module Data.Vector.Utils
( iforM_ ( iforM_
, sort , sort
, sortBy , sortBy
, sortOn , sortOn
, hasDuplicates , hasDuplicates
, imap'
) where ) where
import Data.Ord (comparing) import Data.Ord (comparing)
import Control.Monad (forM_)
import Data.Vector (Vector) import Data.Vector (Vector)
import qualified Data.Vector as V import qualified Data.Vector as V
import qualified Data.Vector.Mutable as VM
import qualified Data.Vector.Algorithms.Intro as V import qualified Data.Vector.Algorithms.Intro as V
iforM_ :: Monad m => Vector a -> (Int -> a -> m b) -> m () iforM_ :: Monad m => Vector a -> (Int -> a -> m b) -> m ()
...@@ -33,3 +37,17 @@ sortOn f = V.modify (V.sortBy (comparing f)) ...@@ -33,3 +37,17 @@ sortOn f = V.modify (V.sortBy (comparing f))
hasDuplicates :: Eq a => Vector a -> Bool hasDuplicates :: Eq a => Vector a -> Bool
hasDuplicates v = V.length (V.uniq v) /= V.length v hasDuplicates v = V.length (V.uniq v) /= V.length v
{-# INLINE hasDuplicates #-} {-# INLINE hasDuplicates #-}
imap' :: (Int -> a -> b) -> Vector a -> Vector b
imap' !f !v = V.create $ do
let !len = (length v)
v' <- VM.new len
forM_ [0..len-1] $ \i -> do
let !a = v V.! i
VM.write v' i (f' i a)
return v'
where
f' !i !a = (f $! i) $! a
...@@ -19,22 +19,23 @@ import MA.Coalgebra.RefinementTypes ...@@ -19,22 +19,23 @@ import MA.Coalgebra.RefinementTypes
import MA.Algorithm.Types import MA.Algorithm.Types
import MA.Algorithm.Initialize import MA.Algorithm.Initialize
import MA.Algorithm.Split import MA.Algorithm.Split
import MA.Algorithm.Internal
processQueue :: RefinementInterface h => BlockQueue s -> AlgoState s h -> ST s () processQueue :: RefinementInterface h => BlockQueue s -> AlgoState s h -> ST s ()
processQueue queue as = whileM $ processQueue queue as = whileM $
Queue.dequeue queue >>= \case Queue.dequeue queue >>= \case
Nothing -> return False Nothing -> return False
Just block -> do Just block -> do
runReaderT (split block) (as, queue) runReaderT (split block) (as, queue)
return True return True
{-# SPECIALIZE processQueue :: BlockQueue s -> AlgoState s TheFunctor -> ST s () #-}
refine :: refine :: forall f s.
RefinementInterface f RefinementInterface f
=> Proxy f => Proxy f
-> Encoding (Label f) (H1 f) -> Encoding (Label f) (H1 f)
-> ST s Partition -> ST s Partition
refine (_ :: Proxy f) encoding = do refine Proxy encoding = do
queue <- Queue.empty (size encoding) queue <- Queue.empty (size encoding)
(blocks, state) <- initialize @f encoding (blocks, state) <- initialize @f encoding
mapM_ (Queue.enqueue queue) blocks mapM_ (Queue.enqueue queue) blocks
...@@ -42,3 +43,4 @@ refine (_ :: Proxy f) encoding = do ...@@ -42,3 +43,4 @@ refine (_ :: Proxy f) encoding = do
processQueue queue state processQueue queue state
Partition.freeze (partition state) Partition.freeze (partition state)
{-# SPECIALIZE refine :: Proxy TheFunctor -> Encoding (Label TheFunctor) (H1 TheFunctor) -> ST s Partition #-}
module MA.Algorithm.Internal (TheFunctor) where
import MA.FunctorExpression.Desorting (Desorted)
import MA.Functors.SomeFunctor (SomeFunctor)
type TheFunctor = Desorted SomeFunctor
...@@ -22,6 +22,7 @@ import Data.Tuple.Extra (snd3) ...@@ -22,6 +22,7 @@ import Data.Tuple.Extra (snd3)
import Data.Vector (Vector) import Data.Vector (Vector)
import qualified Data.Vector as V import qualified Data.Vector as V
import qualified Data.Vector.Mutable as VM import qualified Data.Vector.Mutable as VM
import qualified Data.Vector.Unboxed as VU
import Data.Algorithm.PossibleMajorityCandidate import Data.Algorithm.PossibleMajorityCandidate
import Data.BlockQueue (BlockQueue) import Data.BlockQueue (BlockQueue)
...@@ -33,39 +34,48 @@ import MA.RefinementInterface (RefinementInterface) ...@@ -33,39 +34,48 @@ import MA.RefinementInterface (RefinementInterface)
import qualified MA.RefinementInterface as RI import qualified MA.RefinementInterface as RI
import MA.Coalgebra.RefinementTypes import MA.Coalgebra.RefinementTypes
import MA.Algorithm.Types import MA.Algorithm.Types
import MA.Algorithm.Internal
type SplitM s h = ReaderT (AlgoState s h, BlockQueue s) (ST s) type SplitM s h = ReaderT (AlgoState s h, BlockQueue s) (ST s)
split :: RefinementInterface h => Block -> SplitM s h () split :: RefinementInterface h => Block -> SplitM s h ()
split blockS = do split blockS = do
(as, _) <- ask (as, _) <- ask
statesOfS <- lift $ (Partition.statesOfBlock (partition as) blockS) touchedBlocks <- collectTouchedBlocks blockS
touchedBlocks <- collectTouchedBlocks statesOfS
forM_ touchedBlocks $ \(b, v0) -> do forM_ touchedBlocks $ \(b, v0) -> do
updateBlock b v0 updateBlock b v0
whenM (lift $ Partition.hasMarked (partition as) b) $ whenM (lift $ Partition.hasMarked (partition as) b) $
splitBlock b splitBlock b
{-# SPECIALIZE split :: Block -> SplitM s TheFunctor () #-}
updateBlock :: forall s h. RefinementInterface h => Block -> H3 h -> SplitM s h () updateBlock :: forall s h. RefinementInterface h => Block -> H3 h -> SplitM s h ()
updateBlock b v0 = ask >>= \(as, _) -> lift $ do updateBlock b v0 = ask >>= \(as, _) -> lift $ do
markB <- Partition.markedStates (partition as) b markB <- Partition.markedStates (partition as) b
forM_ markB $ \x -> do VU.forM_ markB $ \x -> do
-- We can use `head` here, since states are only marked if they have at -- We can use `head` here, since states are only marked if they have at
-- least one edge into S => toSub[x] can't be empty. -- least one edge into S => toSub[x] can't be empty.
pc <- (fromEdgeRef . head <$> VM.read (toSub as) x) !pc <- (fromEdgeRef . head <$> VM.read (toSub as) x)
>>= VM.read (lastW as) >>= VM.read (lastW as)
labelsToS <- map (label . graph (encoding as)) <$> VM.read (toSub as) x
(wxS, vx, wxCwithoutS) <- RI.update @h labelsToS <$> readSTRef pc !labelsToS <- {-# SCC readLabels #-} VM.read (toSub as) x >>= (mapM $ \e -> do
writeSTRef pc wxCwithoutS let Edge _ !lab _ = graph (encoding as) e
ps <- newSTRef wxS return $! lab)
VM.read (toSub as) x >>= \edges -> forM_ edges $ \(EdgeRef e) ->
VM.write (lastW as) e ps !pc' <- readSTRef pc
(!wxS, !vx, !wxCwithoutS) <- {-# SCC riupdate #-} return $! (((RI.update @h) $! labelsToS) $! pc')
writeSTRef pc $! {-# SCC wxCwithoutS #-} wxCwithoutS
!ps <- newSTRef $! {-# SCC wxS #-} wxS
VM.read (toSub as) x >>= \(!edges) -> forM_ edges $ \(EdgeRef !e) ->
{-# SCC writelastw #-} (VM.write (lastW as) $! e) $! ps
VM.write (toSub as) x [] VM.write (toSub as) x []
if vx == v0 if vx == v0
then Partition.unmark (partition as) x then Partition.unmark (partition as) x
else VM.write (h3Cache as) x vx else VM.write (h3Cache as) x $! vx
{-# SPECIALIZE updateBlock :: Block -> H3 TheFunctor -> SplitM s TheFunctor () #-}
-- b must have at least one marked state -- b must have at least one marked state
splitBlock :: RefinementInterface h => Block -> SplitM s h () splitBlock :: RefinementInterface h => Block -> SplitM s h ()
...@@ -79,12 +89,12 @@ splitBlock b = ask >>= \(as, queue) -> lift $ do ...@@ -79,12 +89,12 @@ splitBlock b = ask >>= \(as, queue) -> lift $ do
-- effects, this should be safe. -- effects, this should be safe.
let unsafeH3 = unsafeDupablePerformIO . unsafeSTToIO . VM.read (h3Cache as) let unsafeH3 = unsafeDupablePerformIO . unsafeSTToIO . VM.read (h3Cache as)
!pmc <- (possibleMajorityCandidate . V.map unsafeH3) <$> !pmc <- (possibleMajorityCandidateBy' unsafeH3) <$>
Partition.statesOfBlock (partition as) b1 Partition.unsafeStatesOfBlock (partition as) b1
-- the pmc occurs in b1, so b1' has to be non-empty -- the pmc occurs in b1, so b1' has to be non-empty
(Just b1', b2) <- Partition.splitByM (partition as) b1 (Just b1', b2) <- Partition.splitBy (partition as) b1
(fmap (==pmc) . VM.read (h3Cache as)) ((==pmc) . unsafeH3)
blocks <- ((b1':maybeToList bunmarked) ++) <$> case b2 of blocks <- ((b1':maybeToList bunmarked) ++) <$> case b2 of
Nothing -> return [] Nothing -> return []
...@@ -95,6 +105,7 @@ splitBlock b = ask >>= \(as, queue) -> lift $ do ...@@ -95,6 +105,7 @@ splitBlock b = ask >>= \(as, queue) -> lift $ do
ifM (b `Queue.elem` queue) (mapM_ enqueue blocks) $ ifM (b `Queue.elem` queue) (mapM_ enqueue blocks) $
deleteLargest (Partition.blockSize (partition as)) (maybeAdd b blocks) deleteLargest (Partition.blockSize (partition as)) (maybeAdd b blocks)
>>= mapM_ enqueue >>= mapM_ enqueue
{-# SPECIALIZE splitBlock :: Block -> SplitM s TheFunctor () #-}
-- | Remove one largest element from the list -- | Remove one largest element from the list
-- --
...@@ -103,20 +114,24 @@ deleteLargest :: Eq e => (e -> ST s Int) -> [e] -> ST s [e] ...@@ -103,20 +114,24 @@ deleteLargest :: Eq e => (e -> ST s Int) -> [e] -> ST s [e]
deleteLargest sizeFunction lst = do deleteLargest sizeFunction lst = do
zipWithSize <- traverse (\x -> (,x) <$> sizeFunction x) lst zipWithSize <- traverse (\x -> (,x) <$> sizeFunction x) lst
return (delete (snd (maximumBy (compare `on` fst) zipWithSize)) lst) return (delete (snd (maximumBy (compare `on` fst) zipWithSize)) lst)
{-# INLINE deleteLargest #-}
-- | Add element to list if it isn't already there -- | Add element to list if it isn't already there
maybeAdd :: Eq e => e -> [e] -> [e] maybeAdd :: Eq e => e -> [e] -> [e]
maybeAdd e lst maybeAdd e lst
| e `elem` lst = lst | e `elem` lst = lst
| otherwise = e : lst | otherwise = e : lst
{-# INLINE maybeAdd #-}
collectTouchedBlocks :: forall s h. RefinementInterface h => Vector State -> SplitM s h [(Block, H3 h)] collectTouchedBlocks :: forall s h. RefinementInterface h => Block -> SplitM s h [(Block, H3 h)]
collectTouchedBlocks statesOfS = do collectTouchedBlocks blockS = do
(as, _) <- ask (as, _) <- ask
statesOfS <- lift $ Partition.statesOfBlock (partition as) blockS
markedBlocks <- lift $ newSTRef [] markedBlocks <- lift $ newSTRef []
lift $ forM_ statesOfS $ \y -> forM_ (pred as V.! y) $ \e -> do lift $ VU.forM_ statesOfS $ \y -> forM_ (pred as V.! y) $ \e -> do
let Edge x _ _ = graph (encoding as) e let Edge x _ _ = graph (encoding as) e
b <- Partition.blockOfState (partition as) x b <- Partition.blockOfState (partition as) x
...@@ -131,3 +146,4 @@ collectTouchedBlocks statesOfS = do ...@@ -131,3 +146,4 @@ collectTouchedBlocks statesOfS = do
VM.modify (toSub as) (e:) x VM.modify (toSub as) (e:) x
lift $ readSTRef markedBlocks lift $ readSTRef markedBlocks
{-# SPECIALIZE collectTouchedBlocks :: Block -> SplitM s TheFunctor [(Block, H3 TheFunctor)] #-}
...@@ -21,5 +21,3 @@ data AlgoState s h = AlgoState ...@@ -21,5 +21,3 @@ data AlgoState s h = AlgoState
, partition :: RefinablePartition s , partition :: RefinablePartition s
, h3Cache :: MVector s (H3 h) , h3Cache :: MVector s (H3 h)
} }
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
module MA.Coalgebra.Parser module MA.Coalgebra.Parser
( parseMorphisms ( parseMorphisms
, morphismsParser , morphismsParser
, ParseMorphism(..)
, SymbolTable(..) , SymbolTable(..)
, MorphParser , module MA.Coalgebra.Parser.Class
) where ) where
import Data.Void (Void)
import Data.Tuple
import Control.Monad (void) import Control.Monad (void)
import Data.Bifunctor
import Data.Tuple
import Data.Void (Void)
import Control.Monad.State.Strict (StateT, execStateT) import Control.Monad.State.Strict (StateT, execStateT)
import qualified Data.HashMap.Strict as M import qualified Data.HashMap.Strict as M
...@@ -32,13 +34,10 @@ import MA.Coalgebra.Parser.Internal ...@@ -32,13 +34,10 @@ import MA.Coalgebra.Parser.Internal
import MA.Coalgebra.RefinementTypes import MA.Coalgebra.RefinementTypes
import MA.FunctorExpression.Sorts (Sort, Sorted(..)) import MA.FunctorExpression.Sorts (Sort, Sorted(..))
import MA.FunctorExpression.Type import MA.FunctorExpression.Type
import MA.FunctorExpression.Desorting (Desorted)
import qualified MA.Parser.Lexer as L import qualified MA.Parser.Lexer as L
import MA.Parser.Types import MA.Parser.Types
import MA.Coalgebra.Parser.Class
type MorphParser l h1 = StateT (ParserState l h1) Parser
class ParseMorphism f where
parseMorphismPoint :: (Ord x) => f (MorphParser l h1 x) -> MorphParser l h1 (H1 f, Vector (x, Label f))
newState :: MorphParser l h1 State newState :: MorphParser l h1 State
newState = nextState <<%= succ newState = nextState <<%= succ
...@@ -77,8 +76,8 @@ checkUndefinedRefs = use (symbolTable . to M.toList . to (filter isUndefined)) > ...@@ -77,8 +76,8 @@ checkUndefinedRefs = use (symbolTable . to M.toList . to (filter isUndefined)) >
newtype SymbolTable = SymbolTable { fromSymbolTable :: M.HashMap State Text } newtype SymbolTable = SymbolTable { fromSymbolTable :: M.HashMap State Text }
deriving (Show,Eq,Ord,NFData) deriving (Show,Eq,Ord,NFData)
finalizeState :: finalizeState :: forall f.
ParserState l h1 -> (SymbolTable, Encoding (Sorted l) (Sorted h1)) ParserState (Label f) (H1 f) -> (SymbolTable, Encoding (Label (Desorted f)) (H1 (Desorted f)))
finalizeState state = finalizeState state =
let let
h1s = state ^. h1Map h1s = state ^. h1Map
...@@ -92,15 +91,12 @@ finalizeState state = ...@@ -92,15 +91,12 @@ finalizeState state =
in in
(SymbolTable symTab, Encoding.new h1Vec edges) (SymbolTable symTab, Encoding.new h1Vec edges)
toEdges :: (State, (Sort, Vector (State, l))) -> (Vector (Encoding.Edge (Sort, l))) morphismsParser :: forall f.
toEdges (!from, (!sort, !succs)) = V.map (\(!to, !lab) -> Encoding.Edge from (sort, lab) to) succs
morphismsParser ::
(Functor f, ParseMorphism f) (Functor f, ParseMorphism f)
=> FunctorExpression f Sort => FunctorExpression f Sort
-> Parser (SymbolTable, Encoding (Sorted (Label f)) (Sorted (H1 f))) -> Parser (SymbolTable, Encoding (Label (Desorted f)) (H1 (Desorted f)))
morphismsParser Variable = error "should not happen: variable" -- FIXME: Useful error message morphismsParser Variable = error "should not happen: variable" -- FIXME: Useful error message
morphismsParser (Functor sort f) = finalizeState <$> (execStateT p initState) morphismsParser (Functor sort f) = finalizeState @f <$> (execStateT p initState)
where where
p = do p = do
void (some parsePoint) void (some parsePoint)
...@@ -124,7 +120,7 @@ parseMorphisms :: ...@@ -124,7 +120,7 @@ parseMorphisms ::
-> String -> String
-> Text -> Text
-> Either (ParseError Char Void) ( SymbolTable -> Either (ParseError Char Void) ( SymbolTable
, Encoding (Sorted (Label f)) (Sorted (H1 f))) , Encoding (Label (Desorted f)) (H1 (Desorted f)))
parseMorphisms = parse . morphismsParser parseMorphisms = parse . morphismsParser
wrapper :: wrapper ::
......