src/Symantic/Parser.hs

   1 module Symantic.Parser where
   2
   3 import Control.Applicative (Applicative (..))
   4 import Control.Monad (Monad (..))
   5 import Control.Monad.Trans.Except qualified as MT
   6 import Control.Monad.Trans.Reader qualified as MT
   7 import Control.Monad.Trans.State qualified as MT
   8 import Data.Bool (otherwise)
   9 import Data.Either (Either (..))
  10 import Data.Eq (Eq (..))
  11 import Data.Function (id, ($), (.))
  12 import Data.Functor (Functor (..), (<$>))
  13 import Data.Functor.Constant (Constant (..))
  14 import Data.Int (Int)
  15 import Data.Kind (Constraint, Type)
  16 import Data.Maybe (Maybe (..), isJust)
  17 import Data.Proxy (Proxy (..))
  18 import Data.Semigroup (Semigroup (..))
  19 import Data.String (String)
  20 import GHC.Types
  21 import Text.Read (Read (..), reads)
  22 import Text.Show (Show (..))
  23 import Unsafe.Coerce (unsafeCoerce)
  24 import Prelude (error)
  25 import Prelude qualified
  26
  27 import Symantic.Compiler
  28 import Symantic.Typer
  29
  30 -- * Type 'Parser'
  31 data Parser syn = Parser
  32   { unParser ::
  33       ( -- MT.State (TokenTerm a)
  34         Either ErrMsg (TermVT syn)
  35       )
  36   }
  37 type ErrMsg = String
  38 -- * Type 'BinTree'
  39
  40 -- | /Binary Tree/.
  41 data BinTree a
  42   = BinTree0 a
  43   | BinTree2 (BinTree a) (BinTree a)
  44   deriving (Eq, Show)
  45
  46 type TermAST = BinTree TokenTerm
  47 data TokenTerm
  48   = TokenTermAtom String
  49   | TokenTermAbst String (TyVT ()) TermAST
  50   deriving (Show)
  51
  52 safeRead :: Read a => String -> Either ErrMsg a
  53 safeRead s = case reads s of
  54   [(x, "")] -> Right x
  55   _ -> Left $ "Read error: " <> s
  56
  57 {-
  58 instance ( forall sem. syn sem => Functor sem
  59          ) => Functor (Parser syn) where
  60   fmap f (Parser esa) = Parser $
  61     case esa of
  62       Left e -> Left e
  63       Right (ForallSem sem) -> Right (ForallSem (f <$> sem))
  64   a <$ Parser esa = Parser $
  65     case esa of
  66       Left e -> Left e
  67       Right (ForallSem sem) -> Right (ForallSem (a <$ sem))
  68 instance ( forall sem. syn sem => Applicative sem
  69          , Applicative (ForallSem syn)
  70          , forall err. syn (Either err)
  71          , syn (Parser syn) -- FIXME: what constraint is still missing to still require that?
  72          ) => Applicative (Parser syn) where
  73   pure a = Parser (Right (ForallSem (pure a)))
  74   liftA2 f (Parser a) (Parser b) = Parser (liftA2 (liftA2 f) a b)
  75   (<*>) (Parser f) (Parser a) = Parser (liftA2 (<*>) f a)
  76   (*>) (Parser f) (Parser a) = Parser (liftA2 (*>) f a)
  77   (<*) (Parser f) (Parser a) = Parser (liftA2 (<*) f a)
  78 instance ( forall sem. syn sem => Monad sem
  79          , forall err. syn (Either err)
  80          , syn (Parser syn) -- FIXME: what constraint is still missing to still require that?
  81          ) => Monad (Parser syn) where
  82   (>>=) (Parser efsa) f = Parser (efsa >>= \(ForallSem sa) -> sa >>= unParser . f)
  83 -}