haskell: streamline some stuff

haskell/nfker7h/lib/Language/Yanais/Nfker7h/Parser/Lex.hs

@@ -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

haskell/nfker7h/lib/Language/Yanais/Nfker7h/Parser/Types.hs

@@ -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"
 

haskell/nfker7h/lib/Language/Yanais/Parser.hs

@@ -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

haskell/nfker7h/yanais-nfker7h.cabal

@@ -76,6 +76,7 @@ library
         MultiParamTypeClasses
         OverloadedStrings
         RankNTypes
+        TypeFamilies
 
     -- Other library packages from which modules are imported.
     build-depends: