GrammarSemantics.hs 6.7 KB
Newer Older
Sven Keidel's avatar
Sven Keidel committed
1 2 3 4 5 6 7
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module GrammarSemantics where

Jente Hidskes's avatar
Jente Hidskes committed
8
import           Prelude hiding (fail,all,id,(.))
Sven Keidel's avatar
Sven Keidel committed
9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200
import           Result
import           Syntax (Strat(..),Constructor(..),TermVar,StratEnv,TermPattern)
import qualified Syntax as S
import           Interpreter

import           Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import           Data.Text (Text)
import           Data.Hashable
import           Data.Maybe

import           Control.Category
import           Control.Arrow hiding ((<+>))
import           Control.Arrow.Operations
import           Control.Arrow.Transformer.Power
import           Control.Arrow.Transformer.Deduplicate
import           WildcardSemantics (Term(..))

newtype TermRef = TermRef Int deriving (Eq,Hashable,Num)

-- All TermEnv (env,store,maxRef) satisfy
-- * forall x in env, env(x) in store
-- * maxRef not in store
newtype TermEnv = TermEnv (HashMap TermVar TermRef, HashMap TermRef Term, TermRef)

lookup :: (ArrowState TermEnv p, ArrowChoice p, Try p) => p TermVar (Maybe TermRef)
lookup = proc ref -> do
  TermEnv (env,_,_) <- getTermEnv -< ()
  returnA -< M.lookup ref env

deref :: (ArrowState TermEnv p, ArrowChoice p, Try p) => p TermRef Term
deref = proc ref -> do
  TermEnv (env,store,_) <- getTermEnv -< ()
  case M.lookup ref store of
    Just t -> returnA -< t
    Nothing -> returnA -< error "failed to resolve reference"

storeTerm :: ArrowState TermEnv p => p (TermRef,Term) ()
storeTerm = proc (ref,t) -> do
  TermEnv (env,store,maxRef) <- getTermEnv -< ()
  putTermEnv -< TermEnv (env, M.insert ref t store, maxRef)

newTerm :: ArrowState TermEnv p => p Term TermRef
newTerm = proc t -> do
  TermEnv (env,store,maxRef) <- getTermEnv -< ()
  let newRef = maxRef
  putTermEnv -< TermEnv (env,M.insert newRef t store, maxRef + 1)
  returnA -< newRef

eval' :: (ArrowChoice p, ArrowState TermEnv p, ArrowAppend p, Try p, Deduplicate p, ArrowApply p)
      => Int -> StratEnv -> Strat -> p TermRef TermRef
eval' 0 _ _ = proc _ ->
  fail <+> newTerm -< Wildcard
eval' i senv s0 = dedup $ case s0 of
  Id -> id
  S.Fail -> fail
  Seq s1 s2 -> eval' i senv s2 . eval' i senv s1 
  GuardedChoice s1 s2 s3 -> try (eval' i senv s1) (eval' i senv s2) (eval' i senv s3)
  One s -> lift (one (eval' i senv s))
  Some s -> lift (some (eval' i senv s))
  All s -> lift (all (eval' i senv s))
  Scope xs s -> scope xs (eval' i senv s)
  Match f -> undefined --proc t -> match -< (f,t)
  Build f -> undefined --proc _ -> build -< f
  Let bnds body -> let_ senv bnds body (eval' i)
  Call f ss ps -> call senv f ss ps (eval' (i-1))

-- match :: (ArrowChoice p, ArrowState TermEnv p, ArrowAppend p, Try p) => p (TermPattern,Term) Term
-- match = proc (p,t) -> case p of
--   S.Var "_" -> success -< t
--   S.Var x -> do
--     env <- getTermEnv -< ()
--     case M.lookup x env of
--       Just t' -> do
--         t'' <- equal -< (t,t')
--         putTermEnv -< M.insert x t'' env
--         success -< t''
--       Nothing -> do
--         putTermEnv -< M.insert x t env
--         fail <+> success -< t
--   S.Cons c ts -> case t of
--     Cons c' ts'
--       | c == c' && length ts == length ts' -> do
--           ts'' <- zipWith match -< (ts,ts')
--           success -< Cons c ts''
--       | otherwise -> fail -< ()
--     Wildcard -> do
--       ts'' <- zipWith match -< (ts,[Wildcard | _ <- ts])
--       fail <+> success -< Cons c ts''
--     _ -> fail -< ()
--   S.Explode c ts -> case t of
--     Cons (Constructor c') ts' -> do
--       match -< (c,StringLiteral c')
--       match -< (ts, convertToList ts')
--       success -< t
--     StringLiteral _ -> do
--       match -< (ts, convertToList [])
--       success -< t
--     NumberLiteral _ -> do
--       match -< (ts, convertToList [])
--       success -< t
--     Wildcard ->
--       (do
--         match -< (c,  Wildcard)
--         match -< (ts, Wildcard)
--         success -< t)
--       <+>
--       (do
--         match -< (ts, convertToList [])
--         success -< t)
--   S.StringLiteral s -> case t of
--     StringLiteral s'
--       | s == s' -> success -< t
--       | otherwise -> fail -< ()
--     Wildcard -> fail <+> success -< StringLiteral s
--     _ -> fail -< ()
--   S.NumberLiteral n -> case t of
--     NumberLiteral n'
--       | n == n' -> success -< t
--       | otherwise -> fail -< ()
--     Wildcard -> fail <+> success -< NumberLiteral n
--     _ -> fail -< ()

-- equal :: (ArrowChoice p, ArrowAppend p, Try p) => p (Term,Term) Term
-- equal = proc (t1,t2) -> case (t1,t2) of
--   (Cons c ts,Cons c' ts')
--     | c == c' && length ts == length ts' -> do
--       ts'' <- zipWith equal -< (ts,ts')
--       returnA -< Cons c ts''
--     | otherwise -> fail -< ()
--   (StringLiteral s, StringLiteral s')
--     | s == s' -> success -< t1
--     | otherwise -> fail -< ()
--   (NumberLiteral n, NumberLiteral n')
--     | n == n' -> success -< t1
--     | otherwise -> fail -< ()
--   (Wildcard, t) -> fail <+> success -< t
--   (t, Wildcard) -> fail <+> success -< t
--   (_,_) -> fail -< ()

-- build :: (ArrowChoice p, ArrowState TermEnv p, ArrowAppend p, Try p) => p TermPattern Term
-- build = proc p -> case p of
--   S.Var x -> do
--     env <- getTermEnv -< ()
--     case M.lookup x env of
--       Just t -> returnA -< t
--       Nothing -> fail <+> success -< Wildcard
--   S.Cons c ts -> do
--     ts' <- mapA build -< ts
--     returnA -< Cons c ts'
--   S.Explode c ts -> do
--     c' <- build -< c
--     case c' of
--       StringLiteral s -> do
--         ts' <- build -< ts
--         ts'' <- convertFromList -< ts'
--         case ts'' of
--           Just tl -> success -< Cons (Constructor s) tl
--           Nothing -> fail <+> returnA -< Wildcard
--       Wildcard -> fail <+> returnA -< Wildcard
--       _ -> fail -< ()
--   S.NumberLiteral n -> returnA -< NumberLiteral n
--   S.StringLiteral s -> returnA -< StringLiteral s

convertToList :: [Term] -> Term
convertToList ts = case ts of
  (x:xs) -> Cons "Cons" [x,convertToList xs]
  [] -> Cons "Nil" []

convertFromList :: (ArrowChoice p, Try p) => p Term (Maybe [Term])
convertFromList = proc t -> case t of
  Cons "Cons" [x,tl] -> do
    xs <- convertFromList -< tl
    returnA -< (x:) <$> xs
  Cons "Nil" [] ->
    returnA -< Just []
  Wildcard -> returnA -< Nothing
  _ -> fail -< ()

lift :: (Try p,ArrowChoice p,ArrowAppend p)
     => p (Constructor,[Term]) (Constructor,[Term])
     -> p TermRef TermRef
lift p = proc r -> do
  t <- deref -< r
  case t of
    Cons c ts -> do
      (c',ts') <- p -< (c,ts)
      returnA -< Cons c' ts'
    StringLiteral {} -> returnA -< t
    NumberLiteral {} -> returnA -< t
    Wildcard -> fail <+> success -< Wildcard