Parser.hs 4.55 KB
Newer Older
1
{-# LANGUAGE AllowAmbiguousTypes #-}
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
2
{-# LANGUAGE BangPatterns #-}
3
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4
{-# LANGUAGE FlexibleContexts #-}
5
6
7
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
8
{-# LANGUAGE ScopedTypeVariables #-}
9
10
module MA.Coalgebra.Parser
  ( parseMorphisms
11
  , morphismsParser
12
  , SymbolTable(..)
13
  , module MA.Coalgebra.Parser.Class
14
15
  ) where

16
import           Control.Monad (void)
17
18
19
import           Data.Bifunctor
import           Data.Tuple
import           Data.Void (Void)
20

21
import           Control.Monad.State.Strict (StateT, execStateT)
22
23
24
25
26
27
import qualified Data.HashMap.Strict as M
import           Data.Text (Text)
import qualified Data.Text as T
import           Lens.Micro.Platform
import           Text.Megaparsec hiding (State)
import qualified Data.Vector as V
28
import           Data.Vector (Vector)
29
import           Control.DeepSeq (NFData)
30

31
import           Data.MorphismEncoding (Encoding, State)
32
import qualified Data.MorphismEncoding as Encoding
33
import           MA.Coalgebra.Parser.Internal
34
import           MA.Coalgebra.RefinementTypes
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
35
import           MA.FunctorExpression.Sorts (Sort, Sorted(..))
36
import           MA.FunctorExpression.Type
37
import           MA.FunctorExpression.Desorting (Desorted)
38
import qualified MA.Parser.Lexer as L
39
import           MA.Parser.Types
40
import           MA.Coalgebra.Parser.Class
41

42
43
newState :: MorphParser l h1 State
newState = nextState <<%= succ
44
{-# INLINE newState #-}
45

46
defineSymbol :: Text -> MorphParser l h1 State
47
defineSymbol sym = use (symbolTable . at sym) >>= \case
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
48
  Just (_, Defined) -> fail $ T.unpack sym ++ "defined twice" -- TODO: Better error
49
50
  Just (x, Undefined) -> define x
  Nothing -> newState >>= define
51
52

  where
53
54
55
    define :: State -> MorphParser l h1 State
    define node = (symbolTable . at sym .= Just (node, Defined))
      *> return node
56
{-# INLINE defineSymbol #-}
57

58
lookupSymbol :: Text -> MorphParser l h1 State
59
lookupSymbol sym = use (symbolTable . at sym) >>= \case
60
  Nothing -> do { x <- newState; markUndefined x; return x }
61
62
63
  Just (x, _) -> return x

  where
64
    markUndefined :: State -> MorphParser l h1 ()
65
    markUndefined node = symbolTable . at sym .= Just (node, Undefined)
66
{-# INLINE lookupSymbol #-}
67
68
69
70

checkUndefinedRefs :: MorphParser l h1 ()
checkUndefinedRefs = use (symbolTable . to M.toList . to (filter isUndefined)) >>= \case
  [] -> return ()
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
71
  ((sym,_):_) -> fail $ T.unpack sym ++ " is undefined"
72
73
74
75

  where
    isUndefined = (==Undefined) . snd . snd

76
newtype SymbolTable = SymbolTable { fromSymbolTable :: M.HashMap State Text }
77
  deriving (Show,Eq,Ord,NFData)
78

79
80
finalizeState :: forall f.
     ParserState (Label f) (H1 f) -> (SymbolTable, Encoding (Label (Desorted f)) (H1 (Desorted f)))
81
finalizeState state =
82
  let
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
83
84
85
    h1s = state ^. h1Map
    h1Vec = V.generate (M.size h1s) $ \i ->
      case M.lookup i h1s of
86
        Nothing -> error "should not happen" -- FIXME: Handle this case better
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
87
88
89
        Just x -> x
    !edges = V.concat (state ^. graph)
    !symTab = M.fromList (map swap (M.toList (fmap fst (state ^. symbolTable))))
90

91
  in
92
    (SymbolTable symTab, Encoding.new h1Vec edges)
93

94
morphismsParser :: forall f.
95
     (Functor f, ParseMorphism f)
96
  => FunctorExpression f Sort
97
  -> Parser (SymbolTable, Encoding (Label (Desorted f)) (H1 (Desorted f)))
98
morphismsParser Variable = error "should not happen: variable" -- FIXME: Useful error message
99
morphismsParser (Functor sort f) = finalizeState @f <$> (execStateT p initState)
100
101
102
103
104
105
  where
    p = do
      void (some parsePoint)
      checkUndefinedRefs

    parsePoint = do
106
107
      from <- L.name >>= defineSymbol
      void $ L.symbol ":"
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
108
      (h1, succs) <- parseMorphismPoint (fmap wrapper f)
109
      L.newlinesOrEof
110

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
111
112
113
114
115
      !succs' <- V.forM succs $ \(to, l) ->
        return $! Encoding.Edge from (Sorted sort l) to

      graph %= (succs':)
      h1Map %= M.insert from (Sorted sort h1)
116

117
118
119
120
121
parseMorphisms ::
     (Functor f, ParseMorphism f)
  => FunctorExpression f Sort
  -> String
  -> Text
122
  -> Either (ParseError Char Void) ( SymbolTable
123
                                   , Encoding (Label (Desorted f)) (H1 (Desorted f)))
124
125
parseMorphisms = parse . morphismsParser

126
wrapper ::
127
     (Functor f, ParseMorphism f)
128
  => FunctorExpression f Sort
129
  -> MorphParser (Label f) (H1 f) State
130
wrapper Variable = L.name >>= lookupSymbol
131
wrapper (Functor nextSort f) = do
132
  from <- newState
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
133
134
135
136
137
138
139
  (h1, succs) <- parseMorphismPoint (fmap wrapper f)

  !succs' <- V.forM succs $ \(to, l) ->
    return $! Encoding.Edge from (Sorted nextSort l) to

  graph %= (succs':)
  h1Map %= M.insert from (Sorted nextSort h1)
140
  return from