Language/Symantic/Parsing/Test.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE ConstrainedClassMethods #-}
   4 {-# LANGUAGE NoMonomorphismRestriction #-}
   5 {-# LANGUAGE PatternGuards #-}
   6 {-# LANGUAGE TypeInType #-}
   7 {-# LANGUAGE UndecidableInstances #-}
   8 {-# OPTIONS_GHC -fno-warn-orphans #-}
   9 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
  10 module Parsing.Test where
  11
  12 import qualified Data.Char as Char
  13 import qualified Data.MonoTraversable as MT
  14 import qualified Data.Kind as Kind
  15 import Data.Text (Text)
  16 import qualified Data.Text as Text
  17 import qualified Data.List as List
  18 import Data.String (IsString(..))
  19 import Data.Proxy
  20
  21 import Language.Symantic.Parsing
  22 import Language.Symantic.Typing
  23 import Language.Symantic.Compiling (TokenT(..))
  24
  25 -- * Type 'Syntax'
  26 data Syntax a
  27  =   Syntax a [Syntax a]
  28  deriving (Eq)
  29 instance Monoid (Syntax Text) where
  30         mempty = Syntax "" []
  31         mappend (Syntax "" []) x = x
  32         mappend x (Syntax "" []) = x
  33         mappend x y = Syntax " " [x, y]
  34
  35 -- * Class 'Sy'
  36 class Sy c where
  37         type SyT c
  38         sy ::
  39          ( Show_Const '[Proxy c]
  40          , Inj_Const  '[Proxy c] c
  41          ) => SyT c
  42 instance Sy (c::Kind.Type) where
  43         type SyT c = Syntax Text
  44         sy = Syntax (Text.pack $ show_const (inj_const::Const '[Proxy c] c)) []
  45 instance Sy (c::a -> b) where
  46         type SyT c = [Syntax Text] -> Syntax Text
  47         sy = Syntax (Text.pack $ show_const (inj_const::Const '[Proxy c] c))
  48
  49 -- | Custom 'Show' instance a little bit more readable
  50 -- than the automatically derived one.
  51 instance Show (Syntax Text) where
  52         showsPrec p ast@(Syntax name args) =
  53                 let n = Text.unpack name in
  54                 case ast of
  55                  Syntax _ [] -> showString n
  56                  Syntax "(->)" [a] ->
  57                         showParen (p Prelude.<= prec_arrow) $
  58                         showString (""++n++" ") .
  59                         showsPrec prec_arrow a
  60                  Syntax "(->)" [a, b] ->
  61                         showParen (p Prelude.<= prec_arrow) $
  62                         showsPrec prec_arrow a .
  63                         showString (" -> ") .
  64                         showsPrec (prec_arrow Prelude.+ 1) b
  65                  Syntax "\\" [var, typ, body] ->
  66                         showParen (p Prelude.<= prec_lambda) $
  67                         showString ("\\(") .
  68                         showsPrec prec_lambda var .
  69                         showString (":") .
  70                         showsPrec prec_lambda typ .
  71                         showString (") -> ") .
  72                         showsPrec prec_lambda body
  73                  Syntax " " (fun:as) ->
  74                         showParen (p Prelude.<= prec_app) $
  75                         showsPrec prec_dollar fun .
  76                         List.foldl
  77                          (\acc arg ->
  78                                 acc . showString (" ") .
  79                                 showsPrec prec_dollar arg)
  80                          (showString ("")) as
  81                  Syntax "$" [fun, arg] ->
  82                         showParen (p Prelude.<= prec_dollar) $
  83                         showsPrec prec_dollar fun .
  84                         showString (" $ ") .
  85                         showsPrec prec_dollar arg
  86                  _ ->
  87                         showParen (p Prelude.<= prec_app) $
  88                         showString n .
  89                         showString " " .
  90                         showString (List.unwords $ show Prelude.<$> args)
  91                 where
  92                 prec_arrow  = 1
  93                 prec_lambda = 1
  94                 prec_dollar = 1
  95                 prec_app    = 10
  96
  97 -- * Class 'Tokenize'
  98 -- | A minimal parser, dispatched in many class instances.
  99 -- One could also have used a framework like megaparsec,
 100 -- and many class instances to handle 'TokenT's
 101 -- (and be able to handle the fact that
 102 -- they may have a different number of arguments).
 103 -- Here 'TokenizeR' try each 'TokenizeT'
 104 -- up until one works, but this could
 105 -- also be made more efficient by
 106 -- building a 'Map' instead of these nested cases.
 107 type Tokenize ast meta ts = TokenizeR ast meta ts ts
 108
 109 tokenize :: forall meta ast ts. Tokenize ast meta ts
 110  => ast -> Either (Error_Syntax ast) (EToken meta ts)
 111 tokenize = tokenizeR (Proxy::Proxy ts)
 112
 113 -- ** Class 'TokenizeR'
 114 class TokenizeR ast meta ts rs where
 115         tokenizeR :: Proxy rs -> ast -> Either (Error_Syntax ast) (EToken meta ts)
 116 instance
 117  ( TokenizeT ast meta ts (Proxy Token_Var)
 118  , TokenizeR ast meta ts ts
 119  , Inj_Token meta ts (->)
 120  , Monoid meta
 121  ) => TokenizeR ast meta ts '[] where
 122         tokenizeR _rs ast =
 123                 case tokenizeT (Proxy::Proxy (Proxy Token_Var)) ast of
 124                  Nothing -> Left $ Error_Syntax_unsupported ast
 125                  Just (Left err) -> Left err
 126                  Just (Right (as, tok)) ->
 127                         List.foldl (\mf ma -> do
 128                                 a <- tokenize ma
 129                                 f <- mf
 130                                 Right $ EToken $ inj_token (meta_of f `mappend` meta_of a) $
 131                                         Token_Term_App f a
 132                          ) (Right tok) as
 133 instance
 134  ( TokenizeT ast meta ts t
 135  , TokenizeR ast meta ts ts
 136  , TokenizeR ast meta ts rs
 137  , Inj_Token meta ts (->)
 138  ) => TokenizeR ast meta ts (t ': rs) where
 139         tokenizeR _ ast =
 140                 case tokenizeT (Proxy::Proxy t) ast of
 141                  Nothing -> tokenizeR (Proxy::Proxy rs) ast
 142                  Just (Left err) -> Left err
 143                  Just (Right (as, tok)) ->
 144                         List.foldl (\mf ma -> do
 145                                 a <- tokenize ma
 146                                 f <- mf
 147                                 Right $ EToken $ inj_token (meta_of f {-`mappend` meta_of a-}) $
 148                                         Token_Term_App f a
 149                          ) (Right tok) as
 150
 151 -- Type 'Token_Var'
 152 data Token_Var
 153 instance
 154  Inj_Token (Syntax Text) ts (->) =>
 155  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Token_Var) where
 156         tokenizeT _t meta@(Syntax x as)
 157          | Just (x0, xs) <- Text.uncons x
 158          , Char.isLetter x0 && Char.isLower x0
 159          , MT.oall (\c -> Char.isLetter c || Char.isNumber c) xs
 160          = Just $ Right $ (as,) $ EToken $ inj_token meta $
 161                 Token_Term_Var x
 162         tokenizeT _t _sy = Nothing
 163
 164 -- ** Class 'TokenizeT'
 165 class TokenizeT ast meta ts t where
 166         tokenizeT :: Proxy t -> ast
 167          -> Maybe ( Either (Error_Syntax ast)
 168                            ([ast], EToken meta ts) )
 169 instance
 170  ( Inj_Token (Syntax Text) ts (->)
 171  , Tokenize (Syntax Text) (Syntax Text) ts ) =>
 172  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy (->)) where
 173         tokenizeT _t (Syntax "\\" (Syntax n [] : ast_ty : ast_te : as)) = Just $ do
 174                 tok_ty <- tokenize_type ast_ty
 175                 tok_te <- tokenize ast_te
 176                 Right $ (as,) $ EToken $
 177                         inj_token (Syntax "\\" [Syntax n [], ast_ty, ast_te]) $
 178                         Token_Term_Abst n tok_ty tok_te
 179         tokenizeT _t (Syntax " " (ast_f : ast_x : as)) = Just $ do
 180                 tok_f <- tokenize ast_f
 181                 tok_x <- tokenize ast_x
 182                 Right $ (as,) $ EToken $
 183                         inj_token (Syntax " " [ast_f, ast_x]) $
 184                         Token_Term_App tok_f tok_x
 185         tokenizeT _t (Syntax "let" (Syntax n [] : ast_te : ast_in : as)) = Just $ do
 186                 tok_te <- tokenize ast_te
 187                 tok_in <- tokenize ast_in
 188                 Right $ (as,) $ EToken $
 189                         inj_token (Syntax "let" [Syntax n [], ast_te, ast_in]) $
 190                         Token_Term_Let n tok_te tok_in
 191         tokenizeT _t _sy = Nothing
 192 instance
 193  ( Inj_Token (Syntax Text) ts Int
 194  {-, Tokenize (Syntax Text) (Syntax Text) ts-} ) =>
 195  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Int) where
 196         tokenizeT _t (Syntax "int" (ast_i : as)) = Just $ do
 197                 i <- read_syntax ast_i
 198                 Right $ (as,) $ EToken $ inj_token (Syntax "int" [ast_i]) $
 199                         Token_Term_Int i
 200         tokenizeT _t _sy = Nothing
 201 instance
 202  ( Inj_Token (Syntax Text) ts []
 203  , Tokenize (Syntax Text) (Syntax Text) ts ) =>
 204  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy []) where
 205         tokenizeT _t meta@(Syntax "list" (ast_ty : ast_as)) = Just $ do
 206                 typ <- tokenize_type ast_ty
 207                 as <- tokenize `mapM` ast_as
 208                 Right $ ([],) $ EToken $ inj_token meta $
 209                         Token_Term_List_list typ as
 210         tokenizeT _t (Syntax "zipWith" (ast_f : as)) = Just $ do
 211                 f <- tokenize ast_f
 212                 Right $ (as,) $ EToken $ inj_token (Syntax "zipWith" [ast_f]) $
 213                         Token_Term_List_zipWith f
 214         tokenizeT _t _sy = Nothing
 215 instance
 216  ( Inj_Token (Syntax Text) ts Char ) =>
 217  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Char) where
 218         tokenizeT _t (Syntax "char" (ast_c : as)) = Just $ do
 219                 c <- read_syntax ast_c
 220                 Right $ (as,) $ EToken $ inj_token (Syntax "char" [ast_c]) $
 221                         Token_Term_Char c
 222         tokenizeT _t (Syntax "Char.toUpper" as) = Just $
 223                 Right $ (as,) $ EToken $ inj_token (Syntax "Char.toUpper" []) $
 224                         Token_Term_Char_toUpper
 225         tokenizeT _t _sy = Nothing
 226 instance
 227  ( Inj_Token (Syntax Text) ts Text ) =>
 228  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Text) where
 229         tokenizeT _t (Syntax "text" (ast_t : as)) = Just $ do
 230                 t <- read_syntax ast_t
 231                 Right $ (as,) $ EToken $ inj_token (Syntax "text" [ast_t]) $
 232                         Token_Term_Text t
 233         tokenizeT _t _sy = Nothing
 234 instance
 235  ( Inj_Token (Syntax Text) ts Maybe
 236  , Tokenize (Syntax Text) (Syntax Text) ts ) =>
 237  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Maybe) where
 238         tokenizeT _t (Syntax "Just" (ast_a : as)) = Just $ do
 239                 a <- tokenize ast_a
 240                 Right $ (as,) $ EToken $ inj_token (Syntax "Just" [ast_a]) $
 241                         Token_Term_Maybe_Just a
 242         tokenizeT _t _sy = Nothing
 243 instance
 244  ( Inj_Token (Syntax Text) ts (,)
 245  , Tokenize (Syntax Text) (Syntax Text) ts ) =>
 246  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy (,)) where
 247         tokenizeT _t (Syntax "(,)" (ast_a : ast_b : as)) = Just $ do
 248                 a <- tokenize ast_a
 249                 b <- tokenize ast_b
 250                 Right $ (as,) $ EToken $ inj_token (Syntax "(,)" [ast_a, ast_b]) $
 251                         Token_Term_Tuple2 a b
 252         tokenizeT _t (Syntax "fst" (ast_t : as)) = Just $ do
 253                 t <- tokenize ast_t
 254                 Right $ (as,) $ EToken $ inj_token (Syntax "fst" [ast_t]) $
 255                         Token_Term_Tuple2_fst t
 256         tokenizeT _t (Syntax "snd" (ast_t : as)) = Just $ do
 257                 t <- tokenize ast_t
 258                 Right $ (as,) $ EToken $ inj_token (Syntax "snd" [ast_t]) $
 259                         Token_Term_Tuple2_snd t
 260         tokenizeT _t _sy = Nothing
 261 instance
 262  ( Inj_Token (Syntax Text) ts Num
 263  , Tokenize (Syntax Text) (Syntax Text) ts ) =>
 264  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Num) where
 265         tokenizeT _t (Syntax "(+)" (ast_x : as)) = Just $ do
 266                 x <- tokenize ast_x
 267                 Right $ (as,) $ EToken $ inj_token (Syntax "(+)" [ast_x]) $
 268                         Token_Term_Num_add x
 269         tokenizeT _t _sy = Nothing
 270 instance
 271  ( Inj_Token (Syntax Text) ts Monoid
 272  , Tokenize (Syntax Text) (Syntax Text) ts ) =>
 273  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Monoid) where
 274         tokenizeT _t (Syntax "mappend" (ast_x : as)) = Just $ do
 275                 x <- tokenize ast_x
 276                 Right $ (as,) $ EToken $ inj_token (Syntax "mappend" [ast_x]) $
 277                         Token_Term_Monoid_mappend x
 278         tokenizeT _t _sy = Nothing
 279
 280 tokenize_type
 281  :: Inj_Token (Syntax Text) ts Token_Type
 282  => Syntax Text
 283  -> Either (Error_Syntax (Syntax Text)) (EToken (Syntax Text) ts)
 284 tokenize_type meta@(Syntax n as)
 285  | Just (c, _) <- Text.uncons n
 286  , (Char.isUpper c && MT.oall Char.isLetter n)
 287  || MT.oall (\x -> Char.isSymbol x || Char.isPunctuation x)  n =
 288         EToken . inj_token meta . Token_Type n
 289          <$> sequence (tokenize_type <$> as)
 290 tokenize_type syn = Left $ Error_Syntax_unsupported syn
 291
 292 -- * Type 'Error_Syntax'
 293 data Error_Syntax ast
 294  =   Error_Syntax_read ast Text
 295  |   Error_Syntax_unsupported ast
 296  deriving (Eq, Show)
 297
 298 syLam x typ te = Syntax "\\" [syVar x, typ, te]
 299 syVar x = Syntax x []
 300 syApp f x = Syntax " " [f, x]
 301 syLet x b i = Syntax "let" [syVar x, b, i]
 302
 303 syLit :: forall c.
 304  ( Show_Const '[Proxy c]
 305  , Inj_Const  '[Proxy c] c
 306  , Show c
 307  ) => c -> Syntax Text
 308 syLit x = Syntax n [Syntax (Text.pack $ show x) []]
 309         where
 310         c:cs = show_const (inj_const::Const '[Proxy c] c)
 311         n = Text.cons (Char.toLower c) $ Text.pack cs
 312
 313 syFun :: IsString a => [Syntax a] -> Syntax a
 314 syFun = Syntax "(->)"
 315
 316 (.>) :: IsString a => Syntax a -> Syntax a -> Syntax a
 317 a .> b = syFun [a, b]
 318 infixr 3 .>
 319
 320 read_syntax :: Read a => Syntax Text -> Either (Error_Syntax (Syntax Text)) a
 321 read_syntax ast@(Syntax t as) =
 322         case reads $ Text.unpack t of
 323          [(x, "")] | List.null as -> Right x
 324          _ -> Left $ Error_Syntax_read ast t
 325
 326 maybeRight :: Either l r -> Maybe r
 327 maybeRight (Right r) = Just r
 328 maybeRight Left{}    = Nothing