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 type Tokenize ast meta ts = TokenizeR ast meta ts ts
  99
 100 tokenize :: forall meta ast ts. Tokenize ast meta ts
 101  => ast -> Either (Error_Syntax ast) (EToken meta ts)
 102 tokenize = tokenizeR (Proxy::Proxy ts)
 103
 104 -- ** Class 'TokenizeR'
 105 class TokenizeR ast meta ts rs where
 106         tokenizeR :: Proxy rs -> ast -> Either (Error_Syntax ast) (EToken meta ts)
 107 instance
 108  ( TokenizeT ast meta ts (Proxy Token_Var)
 109  , TokenizeR ast meta ts ts
 110  , Inj_Token meta ts (->)
 111  , Monoid meta
 112  ) => TokenizeR ast meta ts '[] where
 113         tokenizeR _rs ast =
 114                 case tokenizeT (Proxy::Proxy (Proxy Token_Var)) ast of
 115                  Nothing -> Left $ Error_Syntax_unsupported ast
 116                  Just (Left err) -> Left err
 117                  Just (Right (as, tok)) ->
 118                         List.foldl (\mf ma -> do
 119                                 a <- tokenize ma
 120                                 f <- mf
 121                                 Right $ EToken $ inj_token (meta_of f `mappend` meta_of a) $
 122                                         Token_Term_App f a
 123                          ) (Right tok) as
 124 instance
 125  ( TokenizeT ast meta ts t
 126  , TokenizeR ast meta ts ts
 127  , TokenizeR ast meta ts rs
 128  , Inj_Token meta ts (->)
 129  ) => TokenizeR ast meta ts (t ': rs) where
 130         tokenizeR _ ast =
 131                 case tokenizeT (Proxy::Proxy t) ast of
 132                  Nothing -> tokenizeR (Proxy::Proxy rs) ast
 133                  Just (Left err) -> Left err
 134                  Just (Right (as, tok)) ->
 135                         List.foldl (\mf ma -> do
 136                                 a <- tokenize ma
 137                                 f <- mf
 138                                 Right $ EToken $ inj_token (meta_of f {-`mappend` meta_of a-}) $
 139                                         Token_Term_App f a
 140                          ) (Right tok) as
 141
 142 -- Type 'Token_Var'
 143 data Token_Var
 144 instance
 145  Inj_Token (Syntax Text) ts (->) =>
 146  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Token_Var) where
 147         tokenizeT _t meta@(Syntax x as)
 148          | Just (x0, xs) <- Text.uncons x
 149          , Char.isLetter x0 && Char.isLower x0
 150          , MT.oall (\c -> Char.isLetter c || Char.isNumber c) xs
 151          = Just $ Right $ (as,) $ EToken $ inj_token meta $
 152                 Token_Term_Var x
 153         tokenizeT _t _sy = Nothing
 154
 155 -- ** Class 'TokenizeT'
 156 class TokenizeT ast meta ts t where
 157         tokenizeT :: Proxy t -> ast
 158          -> Maybe ( Either (Error_Syntax ast)
 159                            ([ast], EToken meta ts) )
 160 instance
 161  ( Inj_Token (Syntax Text) ts (->)
 162  , Tokenize (Syntax Text) (Syntax Text) ts ) =>
 163  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy (->)) where
 164         tokenizeT _t (Syntax "\\" (Syntax n [] : ast_ty : ast_te : as)) = Just $ do
 165                 tok_ty <- tokenize_type ast_ty
 166                 tok_te <- tokenize ast_te
 167                 Right $ (as,) $ EToken $
 168                         inj_token (Syntax "\\" [Syntax n [], ast_ty, ast_te]) $
 169                         Token_Term_Abst n tok_ty tok_te
 170         tokenizeT _t (Syntax " " (ast_f : ast_x : as)) = Just $ do
 171                 tok_f <- tokenize ast_f
 172                 tok_x <- tokenize ast_x
 173                 Right $ (as,) $ EToken $
 174                         inj_token (Syntax " " [ast_f, ast_x]) $
 175                         Token_Term_App tok_f tok_x
 176         tokenizeT _t (Syntax "let" (Syntax n [] : ast_te : ast_in : as)) = Just $ do
 177                 tok_te <- tokenize ast_te
 178                 tok_in <- tokenize ast_in
 179                 Right $ (as,) $ EToken $
 180                         inj_token (Syntax "let" [Syntax n [], ast_te, ast_in]) $
 181                         Token_Term_Let n tok_te tok_in
 182         tokenizeT _t _sy = Nothing
 183 instance
 184  ( Inj_Token (Syntax Text) ts Int
 185  {-, Tokenize (Syntax Text) (Syntax Text) ts-} ) =>
 186  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Int) where
 187         tokenizeT _t (Syntax "int" (ast_i : as)) = Just $ do
 188                 i <- read_syntax ast_i
 189                 Right $ (as,) $ EToken $ inj_token (Syntax "int" [ast_i]) $
 190                         Token_Term_Int i
 191         tokenizeT _t _sy = Nothing
 192 instance
 193  ( Inj_Token (Syntax Text) ts []
 194  , Tokenize (Syntax Text) (Syntax Text) ts ) =>
 195  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy []) where
 196         tokenizeT _t meta@(Syntax "list" (ast_ty : ast_as)) = Just $ do
 197                 typ <- tokenize_type ast_ty
 198                 as <- tokenize `mapM` ast_as
 199                 Right $ ([],) $ EToken $ inj_token meta $
 200                         Token_Term_List_list typ as
 201         tokenizeT _t (Syntax "zipWith" (ast_f : as)) = Just $ do
 202                 f <- tokenize ast_f
 203                 Right $ (as,) $ EToken $ inj_token (Syntax "zipWith" [ast_f]) $
 204                         Token_Term_List_zipWith f
 205         tokenizeT _t _sy = Nothing
 206 instance
 207  ( Inj_Token (Syntax Text) ts Char ) =>
 208  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Char) where
 209         tokenizeT _t (Syntax "char" (ast_c : as)) = Just $ do
 210                 c <- read_syntax ast_c
 211                 Right $ (as,) $ EToken $ inj_token (Syntax "char" [ast_c]) $
 212                         Token_Term_Char c
 213         tokenizeT _t (Syntax "Char.toUpper" as) = Just $
 214                 Right $ (as,) $ EToken $ inj_token (Syntax "Char.toUpper" []) $
 215                         Token_Term_Char_toUpper
 216         tokenizeT _t _sy = Nothing
 217 instance
 218  ( Inj_Token (Syntax Text) ts Text ) =>
 219  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Text) where
 220         tokenizeT _t (Syntax "text" (ast_t : as)) = Just $ do
 221                 t <- read_syntax ast_t
 222                 Right $ (as,) $ EToken $ inj_token (Syntax "text" [ast_t]) $
 223                         Token_Term_Text t
 224         tokenizeT _t _sy = Nothing
 225 instance
 226  ( Inj_Token (Syntax Text) ts Maybe
 227  , Tokenize (Syntax Text) (Syntax Text) ts ) =>
 228  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Maybe) where
 229         tokenizeT _t (Syntax "Just" (ast_a : as)) = Just $ do
 230                 a <- tokenize ast_a
 231                 Right $ (as,) $ EToken $ inj_token (Syntax "Just" [ast_a]) $
 232                         Token_Term_Maybe_Just a
 233         tokenizeT _t _sy = Nothing
 234 instance
 235  ( Inj_Token (Syntax Text) ts (,)
 236  , Tokenize (Syntax Text) (Syntax Text) ts ) =>
 237  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy (,)) where
 238         tokenizeT _t (Syntax "(,)" (ast_a : ast_b : as)) = Just $ do
 239                 a <- tokenize ast_a
 240                 b <- tokenize ast_b
 241                 Right $ (as,) $ EToken $ inj_token (Syntax "(,)" [ast_a, ast_b]) $
 242                         Token_Term_Tuple2 a b
 243         tokenizeT _t (Syntax "fst" (ast_t : as)) = Just $ do
 244                 t <- tokenize ast_t
 245                 Right $ (as,) $ EToken $ inj_token (Syntax "fst" [ast_t]) $
 246                         Token_Term_Tuple2_fst t
 247         tokenizeT _t (Syntax "snd" (ast_t : as)) = Just $ do
 248                 t <- tokenize ast_t
 249                 Right $ (as,) $ EToken $ inj_token (Syntax "snd" [ast_t]) $
 250                         Token_Term_Tuple2_snd t
 251         tokenizeT _t _sy = Nothing
 252 instance
 253  ( Inj_Token (Syntax Text) ts Num
 254  , Tokenize (Syntax Text) (Syntax Text) ts ) =>
 255  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Num) where
 256         tokenizeT _t (Syntax "(+)" (ast_x : as)) = Just $ do
 257                 x <- tokenize ast_x
 258                 Right $ (as,) $ EToken $ inj_token (Syntax "(+)" [ast_x]) $
 259                         Token_Term_Num_add x
 260         tokenizeT _t _sy = Nothing
 261 instance
 262  ( Inj_Token (Syntax Text) ts Monoid
 263  , Tokenize (Syntax Text) (Syntax Text) ts ) =>
 264  TokenizeT (Syntax Text) (Syntax Text) ts (Proxy Monoid) where
 265         tokenizeT _t (Syntax "mappend" (ast_x : as)) = Just $ do
 266                 x <- tokenize ast_x
 267                 Right $ (as,) $ EToken $ inj_token (Syntax "mappend" [ast_x]) $
 268                         Token_Term_Monoid_mappend x
 269         tokenizeT _t _sy = Nothing
 270
 271 tokenize_type
 272  :: Inj_Token (Syntax Text) ts Token_Type
 273  => Syntax Text
 274  -> Either (Error_Syntax (Syntax Text)) (EToken (Syntax Text) ts)
 275 tokenize_type meta@(Syntax n as)
 276  | Just (c, _) <- Text.uncons n
 277  , (Char.isUpper c && MT.oall Char.isLetter n)
 278  || MT.oall (\x -> Char.isSymbol x || Char.isPunctuation x)  n =
 279         EToken . inj_token meta . Token_Type n
 280          <$> sequence (tokenize_type <$> as)
 281 tokenize_type syn = Left $ Error_Syntax_unsupported syn
 282
 283 -- * Type 'Error_Syntax'
 284 data Error_Syntax ast
 285  =   Error_Syntax_read ast Text
 286  |   Error_Syntax_unsupported ast
 287  deriving (Eq, Show)
 288
 289 syLam x typ te = Syntax "\\" [syVar x, typ, te]
 290 syVar x = Syntax x []
 291 syApp f x = Syntax " " [f, x]
 292 syLet x b i = Syntax "let" [syVar x, b, i]
 293
 294 syLit :: forall c.
 295  ( Show_Const '[Proxy c]
 296  , Inj_Const  '[Proxy c] c
 297  , Show c
 298  ) => c -> Syntax Text
 299 syLit x = Syntax n [Syntax (Text.pack $ show x) []]
 300         where
 301         c:cs = show_const (inj_const::Const '[Proxy c] c)
 302         n = Text.cons (Char.toLower c) $ Text.pack cs
 303
 304 syFun :: IsString a => [Syntax a] -> Syntax a
 305 syFun = Syntax "(->)"
 306
 307 (.>) :: IsString a => Syntax a -> Syntax a -> Syntax a
 308 a .> b = syFun [a, b]
 309 infixr 3 .>
 310
 311 read_syntax :: Read a => Syntax Text -> Either (Error_Syntax (Syntax Text)) a
 312 read_syntax ast@(Syntax t as) =
 313         case reads $ Text.unpack t of
 314          [(x, "")] | List.null as -> Right x
 315          _ -> Left $ Error_Syntax_read ast t
 316
 317 maybeRight :: Either l r -> Maybe r
 318 maybeRight (Right r) = Just r
 319 maybeRight Left{}    = Nothing