Created
March 13, 2014 09:07
-
-
Save 314maro/9524814 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
### ラムダ | |
🐫 変数👉 式 | |
### 括弧 | |
🌜 式🌛 | |
### コメント | |
🌝 コメ🌝 ネストできる🌞 ント🌞 | |
### 例 | |
🐫 🐭 👉 🐫 🐮 👉 🐫 🐯 👉 🐭 🐯 🌜 🐮 🐯 🌛 🌝 Sコンビネータ🌞 | |
### バグ | |
変数まわりにバグがある | |
ド・ブラン インデックス を使うのかな |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
import Control.Applicative | |
import qualified Text.Trifecta as T | |
import qualified Text.Parser.Token.Style as TS | |
import qualified Data.HashSet as H | |
import Data.Monoid (mempty) | |
import Data.Char | |
main = getLine >>= run | |
run code = case T.parseString (runComment expr) mempty code of | |
T.Failure d -> print d | |
T.Success s -> print $ eval s | |
data Expr = Fun String Expr | |
| Var String | |
| App Expr Expr | |
showParen' True s = ("🌜 " ++) . s . ("🌛 " ++) | |
showParen' False s = s | |
instance Show Expr where | |
showsPrec n (Fun v e) = showParen' (n > 9) $ \s -> "🐫 " ++ v ++ " 👉 " ++ shows e s | |
showsPrec n (Var v) = (v ++) . (' ' :) | |
showsPrec n (App e1 e2) = showParen' (n > 10) $ showsPrec 10 e1 . showsPrec 11 e2 | |
{- | |
elem' :: String -> Expr -> Bool | |
elem' v (Fun u e) = v /= u && elem' v e | |
elem' v (Var u) = v == u | |
elem' v (App e1 e2) = elem' v e1 || elem' v e2 | |
-} | |
subst :: String -> Expr -> Expr -> Expr | |
subst name v e = go e | |
where | |
go (Fun u e) | |
| name == u = Fun u e | |
-- | u `elem'` v = | |
| otherwise = Fun u (go e) | |
go (Var u) | |
| name == u = v | |
| otherwise = Var u | |
go (App e1 e2) = App (go e1) (go e2) | |
eval :: Expr -> Expr | |
eval (App f x) = case (eval f, eval x) of | |
(Fun name e, x) -> eval $ subst name x e | |
(f, x) -> App f x | |
eval e = e | |
newtype Comment a = Comment { runComment :: T.Parser a } | |
deriving (Functor,Applicative,Alternative,Monad,T.Parsing,T.CharParsing) | |
instance T.TokenParsing Comment where | |
nesting (Comment m) = Comment (T.nesting m) | |
someSpace = TS.buildSomeSpaceParser (Comment T.someSpace) style | |
where | |
style = TS.emptyCommentStyle | |
{ TS._commentStart = "🌝" , TS._commentEnd = "🌞" } | |
semi = Comment T.semi | |
highlight h (Comment m) = Comment (T.highlight h m) | |
var :: Comment String | |
var = T.ident style | |
where | |
char = T.satisfy $ \c -> generalCategory c == OtherSymbol && not (c `elem` reserved) | |
style = (TS.emptyIdents :: T.IdentifierStyle Comment) | |
{ T._styleStart = char | |
, T._styleLetter = char | |
, T._styleReserved = H.fromList $ map (:[]) reserved | |
} | |
reserved = ['🐫','👉','🌜','🌛','🌝','🌞'] | |
expr' :: Comment Expr | |
expr' = T.chainl1 fact (pure App) | |
fact :: Comment Expr | |
fact = T.between (T.symbolic '🌜') (T.symbolic '🌛') expr | |
<|> (Var <$> var) | |
expr :: Comment Expr | |
expr = (Fun <$ T.symbolic '🐫' <*> var <* T.symbolic '👉' <*> expr) | |
<|> expr' |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment