Language/Symantic/Compiling/Term/Test.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 module Compiling.Term.Test where
   4
   5 import Test.Tasty
   6 import Test.Tasty.HUnit
   7
   8 import qualified Control.Arrow as Arrow
   9 import qualified Control.Monad as Monad
  10 import qualified Control.Monad.Classes as MC
  11 import qualified Control.Monad.Classes.Run as MC
  12 -- import Control.Monad.IO.Class (MonadIO(..))
  13 import qualified Control.Monad.Trans.State.Strict as SS
  14 import qualified Data.Foldable as Foldable
  15 import Data.Functor.Identity (Identity(..))
  16 import qualified Data.Map.Strict as Map
  17 import Data.Proxy (Proxy(..))
  18 import Data.Text (Text)
  19 import Data.Type.Equality ((:~:)(Refl))
  20 import Prelude as Pre
  21 import qualified Text.Megaparsec as P
  22
  23 import Language.Symantic.Compiling
  24 import Language.Symantic.Interpreting
  25 import Language.Symantic.Parsing
  26 import qualified Language.Symantic.Parsing.Grammar as Gram
  27 import Language.Symantic.Typing
  28
  29 import Parsing.Grammar.Test
  30 import Typing.Test ()
  31
  32 type Meta = ()
  33
  34 ---
  35 -- P.ParsecT instances
  36 ---
  37 type instance MC.CanDo (P.ParsecT e s m) eff = 'False
  38 instance ParsecC e s => Gram_Term_Name (P.ParsecT e s m)
  39 instance ParsecC e s => Gram.Gram_Meta Meta (P.ParsecT e s m) where
  40         metaG = (($ ()) Pre.<$>)
  41 instance
  42  ( ParsecC e s
  43  , Gram.Gram_Meta meta (P.ParsecT e s m)
  44  ) => Gram_Term_Type meta (P.ParsecT e s m)
  45 instance
  46  ( ParsecC e s
  47  ) => Gram_Error (P.ParsecT e s m) where
  48         term_unError (Gram.CF me) = Gram.CF $ do
  49                 e <- me
  50                 case e of
  51                  Left err -> Monad.fail $ Pre.show err
  52                  Right a -> Monad.return a
  53 instance
  54  ( ParsecC e s
  55  , Gram.Gram_Meta meta (P.ParsecT e s m)
  56  , MC.MonadState (Tokenizers meta ts) m
  57  , Gram_Term_AtomsR meta ts ts (P.ParsecT e s m)
  58  ) => Gram_Term ts meta (P.ParsecT e s m) where
  59         term_tokenizers (Gram.CF ma) = Gram.CF $ do
  60                 a <- ma
  61                 toks :: Tokenizers meta ts <- MC.get
  62                 Monad.return $ a toks
  63         term_abst_args_body (Gram.CF args) (Gram.CF body) = Gram.CF $ do
  64                 as <- args
  65                 bo <- do
  66                         toks :: Tokenizers meta ts <- MC.get
  67                         MC.put $
  68                                 Tokenizers
  69                                  { tokenizers_prefix  = del (tokenizers_prefix  toks) as
  70                                  , tokenizers_infix   = del (tokenizers_infix   toks) as
  71                                  , tokenizers_postfix = del (tokenizers_postfix toks) as
  72                                  }
  73                         body Pre.<* MC.put toks
  74                 Monad.return (as, bo)
  75                 where del = Foldable.foldr (\(n, _) -> Map.adjust (Map.delete n) [])
  76
  77 test_tokenizer :: forall is.
  78  ( Inj_Tokens Meta is [Proxy (->), Proxy Integer]
  79  , Gram_Term is Meta (P.ParsecT P.Dec String (SS.StateT (Tokenizers Meta is) Identity))
  80  , Tokenize Meta is
  81  ) => String -> Either (P.ParseError Char P.Dec) (EToken Meta is)
  82 test_tokenizer inp =
  83         runIdentity $
  84         MC.evalStateStrict (tokenizers::Tokenizers Meta is) $
  85         (`runParserT` inp) $
  86         Gram.unCF $ (termG Pre.<* Gram.eoi)
  87
  88 test_compile
  89  :: forall is h.
  90  ( Eq h
  91  , Eq_Token Meta is
  92  , Show h
  93  , Show_Const (Consts_of_Ifaces is)
  94  , Show_Token Meta is
  95  , Sym_of_Ifaces is HostI
  96  , Sym_of_Ifaces is TextI
  97  , Compile is
  98  , Inj_Tokens Meta is [Proxy (->), Proxy Integer]
  99  , Gram_Term is Meta (P.ParsecT P.Dec String (SS.StateT (Tokenizers Meta is) Identity))
 100  , Tokenize Meta is
 101  ) => Proxy is
 102  -> String
 103  -> Either ( Type (Consts_of_Ifaces is) h
 104            , Either (P.ParseError Char P.Dec)
 105                     (Error_Term Meta is) )
 106            (Type (Consts_of_Ifaces is) h, h, Text)
 107  -> TestTree
 108 test_compile _is inp expected =
 109         testCase (elide inp) $
 110         case test_tokenizer inp of
 111          Left err -> Left (Left err) @?= Pre.snd `Arrow.left` expected
 112          Right tok ->
 113                 case compile tok of
 114                  Left err -> Left (Right err) @?= Pre.snd `Arrow.left` expected
 115                  Right (ETerm typ (Term te)) ->
 116                         case expected of
 117                          Left (_, err) -> Right ("…"::Text) @?= Left err
 118                          Right (ty_expected::Type (Consts_of_Ifaces is) h, _::h, _::Text) ->
 119                                 (Monad.>>= (@?= (\(_::Type (Consts_of_Ifaces is) h, err) -> err) `Arrow.left` expected)) $
 120                                 case typ `eq_type` ty_expected of
 121                                  Nothing -> Monad.return $ Left $ Right $
 122                                         Error_Term_Constraint_Type $ Right $
 123                                         Constraint_Type_Eq
 124                                          (Right $ At Nothing $ EType typ)
 125                                          (At Nothing $ EType ty_expected)
 126                                  Just Refl -> do
 127                                         let h = host_from_term te
 128                                         Monad.return $
 129                                                 Right
 130                                                  ( typ
 131                                                  , h
 132                                                  , text_from_term te
 133                                                  -- , (text_from_term :: Repr_Text h -> Text) r
 134                                                  )
 135
 136 maybeRight :: Either l r -> Maybe r
 137 maybeRight (Right r) = Just r
 138 maybeRight Left{}    = Nothing