csg/p.icl

   1 module p
   2
   3 import StdEnv
   4
   5 import Data.Func
   6 import Data.Functor
   7 import Data.Tuple
   8 import Data.Maybe
   9 import Control.Applicative
  10 import Control.Monad
  11
  12 :: Parser m a = Parser (ParseState -> m (a, ParseState))
  13 :: ParseState =
  14         { tokens   :: [Char]
  15         , infixers :: [Infixer]
  16         }
  17 :: Infixer = Infxer Bool Int [Char]
  18
  19 runParser :: (Parser m a) -> (ParseState -> m (a, ParseState))
  20 runParser (Parser a) = a
  21
  22 instance Functor (Parser m) | Monad m where fmap a b = liftM a b
  23 instance pure (Parser m) | Monad m where pure a = Parser (pure o tuple a)
  24 instance <*> (Parser m) | Monad m where (<*>) a b = ap a b
  25 instance <* (Parser m) | Monad m
  26 instance *> (Parser m) | Monad m
  27 instance Monad (Parser m) | Monad m where
  28         bind ma a2mb = Parser \c->runParser ma c >>= uncurry (runParser o a2mb)
  29 instance Alternative (Parser m) | Alternative m where
  30         empty = Parser (pure empty)
  31         (<|>) l r = Parser \c->runParser l c <|> runParser r c
  32
  33 get :: Parser m ParseState | Alternative, Monad m
  34 get = Parser \c->pure (c, c)
  35
  36 set :: ParseState -> Parser m () | Alternative, Monad m
  37 set c = Parser \_->pure ((), c)
  38
  39 upd :: (ParseState -> ParseState) -> Parser m () | Alternative, Monad m
  40 upd f = f <$> get >>= set
  41
  42 pTop :: Parser m Char | Alternative, Monad m
  43 pTop = get >>= \c->case c.tokens of
  44         [] = empty
  45         [t:ts] = set {c & tokens=ts} *> pure t
  46
  47 pSatisfy :: (Char -> Bool) -> Parser m Char | Alternative, Monad m
  48 pSatisfy f = pTop >>= \t->if (f t) (pure t) empty
  49
  50 pToken :: Char -> Parser m Char | Alternative, Monad m
  51 pToken c = pSatisfy ((==)c)
  52
  53 (<:>) infixr 1
  54 (<:>) l r :== (\x xs->[x:xs]) <$> l <*> r
  55
  56 pTokens :: [Char] -> Parser m [Char] | Alternative, Monad m
  57 pTokens ts = foldr (<:>) (pure []) (map pToken ts)
  58
  59 pChainL :: (Parser m (a a -> a)) (Parser m a) -> Parser m a | Alternative, Monad m
  60 pChainL op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
  61
  62 :: Program :== [([Char], Expr)]
  63 :: Expr
  64         = Var [Char]
  65         | Lit Int
  66         | BinOp [Char] Expr Expr
  67
  68 pProgram :: Parser m Program | Alternative, Monad m
  69 pProgram = many pDecl
  70
  71 pDecl :: Parser m ([Char], Expr) | Alternative, Monad m
  72 pDecl = tuple <$> many (pSatisfy isAlpha) <* pToken '=' <*> pExpr <* pToken '\n'
  73
  74 pInfixer :: Parser m Program | Alternative, Monad m
  75 pInfixer = Infxer o (==) 'r' <$ pTokens ['ifx'] <*> (pToken 'r' <|> pToken 'l') <*> pLit <*> many (pSatisfy isOpChar)
  76         >>= \_->pure []
  77
  78 pExpr :: Parser m Expr | Alternative, Monad m
  79 pExpr = pChainL (BinOp <$> pTokens ['+']) $
  80             Lit <$> pLit
  81         <|> Var <$> many (pSatisfy isAlpha)
  82         <|> pToken '(' *> pExpr <* pToken ')'
  83
  84 pLit :: Parser m Int | Alternative, Monad m
  85 pLit = ((~) <$ pToken '-' <|> pure id) <*>
  86         (toInt <$> toString <$> some (pSatisfy isDigit))
  87
  88 isOpChar :: Char -> Bool
  89 isOpChar c = isMember c ['-+*/%@#$^&=|\'']
  90
  91 printProgram :: [([Char], Expr)] -> String
  92 printProgram p = foldr (+++) ""
  93         [toString c +++ "=" +++ printExpr e\\(c, e)<-p]
  94
  95 printExpr :: Expr -> String
  96 printExpr (Var i) = toString i
  97 printExpr (Lit i) = toString i
  98 printExpr (BinOp o l r) = "(" +++ printExpr l +++ toString o +++ printExpr r +++ ")"
  99
 100 Start :: Maybe (String, ParseState)
 101 Start = appFst printProgram <$> runParser pProgram {tokens=['y=x+4\n'],infixers=[]}