haskell: streamline some stuff
This commit is contained in:
parent
b1531384ef
commit
31c6f1a717
4 changed files with 23 additions and 48 deletions
|
@ -17,9 +17,6 @@ data Keyword = KwLambda | KwType deriving (Show)
|
|||
|
||||
data Token = Token !Span TokenKind deriving (Show)
|
||||
|
||||
instance MaybeGetSpan Token where
|
||||
mgSpan (Token s _) = Just s
|
||||
|
||||
data TokenKind = TIdent Ident
|
||||
| TPatOut Ident -- this ident might be empty
|
||||
| TDotIdent Ident
|
||||
|
|
|
@ -1,20 +1,17 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE DeriveGeneric, MultiParamTypeClasses, TypeFamilies #-}
|
||||
|
||||
module Language.Yanais.Nfker7h.Parser.Types (
|
||||
Context(..),
|
||||
Result(..),
|
||||
Error(..),
|
||||
MaybeGetSpan(..)
|
||||
) where
|
||||
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.Text.Encoding.Error (UnicodeException)
|
||||
import Generic.Data (Generic)
|
||||
import qualified Language.Yanais.Parser as P
|
||||
|
||||
-- a "classic" tristate result
|
||||
data Result t = RSome t | RNone | RError P.Span Error
|
||||
|
||||
data Context = CtxModule
|
||||
data Context = CtxModule deriving (Eq, Generic)
|
||||
instance Hashable Context
|
||||
|
||||
data Error = UnexpectedEof Context
|
||||
| UnexpectedChar !Int !Char
|
||||
|
@ -22,36 +19,10 @@ data Error = UnexpectedEof Context
|
|||
| DteUnicodeExc UnicodeException
|
||||
| UnknownIdent !P.Ident
|
||||
|
||||
instance P.ParserError P.ParserEnv Error where
|
||||
instance P.ParserError Error where
|
||||
type PErrEnv Error = P.ParserEnv
|
||||
perrUnknown st = AlternativeErr (P.peOffset st)
|
||||
|
||||
instance Functor Result where
|
||||
fmap f (RSome x) = RSome (f x)
|
||||
fmap _ RNone = RNone
|
||||
fmap _ (RError s e) = RError s e
|
||||
|
||||
instance Applicative Result where
|
||||
pure = RSome
|
||||
RNone <*> _ = RNone
|
||||
(RError s e) <*> _ = RError s e
|
||||
_ <*> RNone = RNone
|
||||
_ <*> (RError s e) = RError s e
|
||||
(RSome f) <*> (RSome x) = RSome (f x)
|
||||
|
||||
instance Monad Result where
|
||||
return = pure
|
||||
(RSome x) >>= thn = thn x
|
||||
RNone >>= _ = RNone
|
||||
(RError s e) >>= _ = RError s e
|
||||
|
||||
class MaybeGetSpan a where
|
||||
mgSpan :: a -> Maybe P.Span
|
||||
|
||||
instance MaybeGetSpan t => MaybeGetSpan (Result t) where
|
||||
mgSpan (RSome x) = mgSpan x
|
||||
mgSpan RNone = Nothing
|
||||
mgSpan (RError s _) = Just s
|
||||
|
||||
instance Show Context where
|
||||
show CtxModule = "module level"
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE
|
||||
DeriveGeneric, FlexibleInstances, MultiParamTypeClasses,
|
||||
OverloadedStrings, TypeFamilies
|
||||
#-}
|
||||
|
||||
module Language.Yanais.Parser (
|
||||
Text,
|
||||
|
@ -62,9 +62,15 @@ instance Semigroup Span where
|
|||
Span start1 end1 <> Span start2 end2 = Span (min start1 start2) (max end1 end2)
|
||||
|
||||
-- misc failure conditions
|
||||
class ParserError s e where
|
||||
-- an unknown error (the state might indicate where the error happened)
|
||||
perrUnknown :: s -> e
|
||||
class ParserError e where
|
||||
type PErrEnv e :: *
|
||||
|
||||
-- | an unknown error (the state might indicate where the error happened)
|
||||
perrUnknown :: PErrEnv e -> e
|
||||
|
||||
-- | possible error chaining (the default impl discards the first error)
|
||||
perrMerge :: e -> e -> e
|
||||
perrMerge _ b = b
|
||||
|
||||
-- a generic parser monad
|
||||
newtype Parser s e a = Parser { runP :: StateT s (Either e) a }
|
||||
|
@ -79,13 +85,13 @@ instance Applicative (Parser s e) where
|
|||
Parser a <*> Parser b = Parser $ a <*> b
|
||||
{-# INLINE (<*>) #-}
|
||||
|
||||
instance ParserError s e => Alternative (Parser s e) where
|
||||
instance (ParserError e, PErrEnv e ~ s) => Alternative (Parser s e) where
|
||||
empty = Parser $ StateT (Left . perrUnknown)
|
||||
Parser (StateT p1) <|> Parser (StateT p2) = Parser . StateT $ \st ->
|
||||
case (p1 st, p2 st) of
|
||||
(Right y, _) -> Right y
|
||||
(_, Right y) -> Right y
|
||||
(Left _, Left e) -> Left e
|
||||
(Left e1, Left e2) -> Left $ perrMerge e1 e2
|
||||
|
||||
instance Monad (Parser s e) where
|
||||
return = pure
|
||||
|
|
|
@ -76,6 +76,7 @@ library
|
|||
MultiParamTypeClasses
|
||||
OverloadedStrings
|
||||
RankNTypes
|
||||
TypeFamilies
|
||||
|
||||
-- Other library packages from which modules are imported.
|
||||
build-depends:
|
||||
|
|
Loading…
Reference in a new issue