FreeParser.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
import Control.Monad
import Control.Applicative
import Control.Monad.Skeleton
import qualified Data.Map as M
import Text.Trifecta

type Var = String
data Syntax k = forall a. Syntax { runSyntax :: (k a, Maybe Var) }

pbind :: Parser (k a) -> Parser (Syntax k)
pbind parser = do
  var <- option Nothing $ try $ do
    Just <$> some letter <* spaces <* symbol "<-"
  ka <- parser
  return $ Syntax (ka,var)

fromConParsers :: [Parser (Syntax k)] -> Parser [Syntax k]
fromConParsers = many . choice . fmap try where

class Resolver dsl where
  type ValUniv dsl :: *
  toValue :: dsl Either a -> (a -> ValUniv dsl)
  resolve :: M.Map Var (ValUniv dsl) -> dsl Either a -> dsl Const a

skeletonize :: Resolver dsl => [Syntax (dsl Either)] -> Skeleton (dsl Const) ()
skeletonize = go M.empty where
  mayInsert Nothing r = id
  mayInsert (Just ref) r = M.insert ref r

  go :: Resolver dsl => M.Map Var (ValUniv dsl) -> [Syntax (dsl Either)] -> Skeleton (dsl Const) ()
  go _ [] = return ()
  go mp (x:xs) = case x of
    (Syntax (op,ref)) -> do
      r <- bone $ resolve mp op
      go (mayInsert ref (toValue op r) mp) xs

-- simple example
-- shared-var machine DSL

data DSL ref a where
  Add :: ref Int Var -> DSL ref ()
  Double :: DSL ref ()
  Get :: DSL ref Int
  Print :: DSL ref ()

data BindVal = VU () | VInt Int

instance Show (DSL Either a) where
  show (Add n) = "Add(" ++ show n ++ ")"
  show Double = "Double"
  show Get = "Get"
  show Print = "Print"

-- Show (k a) => Show (Syntax k) が書ければよいが…
instance Show (Syntax (DSL Either)) where
  show (Syntax (ka, Nothing)) = show ka
  show (Syntax (ka, Just v)) = v ++ " <- " ++ show ka
  
pDSL :: Parser [Syntax (DSL Either)]
pDSL = fromConParsers $ 
  [ pbind padd
  , pbind pduplicate
  , pbind pget
  , pbind pprint
  ]

  where
    padd = do
      symbol "Add"
      choice $ fmap try $
        [ Add . Left . fromInteger <$> integer
        , Add . Right <$> some letter <* newline
        ]
    pduplicate = (\_ -> Double) <$> symbol "Double"
    pget = (\_ -> Get) <$> symbol "Get"
    pprint = (\_ -> Print) <$> symbol "Print"

instance Resolver DSL where
  type ValUniv DSL = BindVal
  toValue (Add _) = VU
  toValue Double = VU
  toValue Get = VInt
  toValue Print = VU

  resolve mp (Add (Left n)) = Add (Const n)
  resolve mp (Add (Right ref)) = Add $ Const $ (\(VInt v) -> v) $ mp M.! ref
  resolve mp Double = Double
  resolve mp Get = Get
  resolve mp Print = Print

interpret :: Skeleton (DSL Const) () -> IO ()
interpret = go 0 where
  go :: Int -> Skeleton (DSL Const) () -> IO ()
  go st skel = case debone skel of
    (Add (Const n) :>>= next) -> go (st + n) (next ())
    (Double :>>= next) -> go (st * 2) (next ())
    (Get :>>= next) -> go st (next st)
    (Print :>>= next) -> print st >> go st (next ())
    Return _ -> return ()

main = do
  syn <- return $ parseString pDSL mempty $
    "Print\n\
    \Add 10\n\
    \Print\n\
    \n <- Get\n\
    \Double\n\
    \m <- Get\n\
    \Print\n\
    \Add n\n\
    \Add m\n\
    \Print"

  case syn of
    Success s -> interpret $ skeletonize s

  -- result:
  -- 0
  -- 10
  -- 20
  -- 50