SharedSemantics.hs 5.69 KB
Newer Older
Sven Keidel's avatar
Sven Keidel committed
1 2 3 4 5 6 7 8
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ConstraintKinds #-}
module SharedSemantics where

Jente Hidskes's avatar
Jente Hidskes committed
9
import           Prelude hiding (id,all,sequence)
Sven Keidel's avatar
Sven Keidel committed
10 11 12 13 14 15 16 17

import           Syntax hiding (Fail,TermPattern(..))
import           Syntax (TermPattern)
import qualified Syntax as S
import           Utils

import           Control.Arrow
import           Control.Arrow.Deduplicate
18 19 20 21
import           Control.Arrow.Fail
import           Control.Arrow.Fix
import           Control.Arrow.Try
import           Control.Arrow.Utils hiding (mapA,zipWithA)
Sven Keidel's avatar
Sven Keidel committed
22 23 24 25 26 27 28 29 30 31
import           Control.Category

import qualified Data.HashMap.Lazy as M
import           Data.Term
import           Data.TermEnv
import           Data.Hashable

import           Text.Printf

-- Shared interpreter for Stratego
32
eval' :: (ArrowChoice c, ArrowTry c, ArrowPlus c, ArrowApply c, ArrowFix' c t,
33
          ArrowFail () c, ArrowDeduplicate c, Eq t, Hashable t,
Sven Keidel's avatar
Sven Keidel committed
34 35
          HasStratEnv c, IsTerm t c, IsTermEnv env t c)
      => (Strat -> c t t)
36
eval' = fixA' $ \ev s0 -> dedupA $ case s0 of
Sven Keidel's avatar
Sven Keidel committed
37
    Id -> id
38
    S.Fail -> failA'
Sven Keidel's avatar
Sven Keidel committed
39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55
    Seq s1 s2 -> sequence (ev s1) (ev s2)
    GuardedChoice s1 s2 s3 -> guardedChoice (ev s1) (ev s2) (ev s3)
    One s -> mapSubterms (one (ev s))
    Some s -> mapSubterms (some (ev s))
    All s -> mapSubterms (all (ev s))
    Scope xs s -> scope xs (ev s)
    Match f -> proc t -> match -< (f,t)
    Build f -> proc _ -> build -< f
    Let bnds body -> let_ bnds body eval'
    Call f ss ps -> call f ss ps ev

guardedChoice :: ArrowTry c => c x y -> c y z -> c x z -> c x z
guardedChoice = tryA

sequence :: Category c => c x y -> c y z -> c x z
sequence f g = f >>> g

56
one :: (ArrowChoice c, ArrowFail () c, ArrowTry c, ArrowPlus c) => c t t -> c [t] [t]
Sven Keidel's avatar
Sven Keidel committed
57 58 59 60 61 62
one f = proc l -> case l of
  (t:ts) -> do
    (t',ts') <- first f <+> second (one f) -< (t,ts)
    returnA -< (t':ts')
  [] -> failA -< ()

63
some :: (ArrowChoice c, ArrowFail () c, ArrowTry c) => c t t -> c [t] [t]
Sven Keidel's avatar
Sven Keidel committed
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
some f = go
  where
    go = proc l -> case l of
      (t:ts) -> do
        (t',ts') <- tryA (first f) (second go') (second go) -< (t,ts)
        returnA -< t':ts'
      -- the strategy did not succeed for any of the subterms, i.e. some(s) fails
      [] -> failA -< ()
    go' = proc l -> case l of
      (t:ts) -> do
        (t',ts') <- tryA (first f) (second go') (second go') -< (t,ts)
        returnA -< t':ts'
      [] -> returnA -< []

all :: ArrowChoice c => c x y -> c [x] [y]
all = mapA

scope :: IsTermEnv env t c => [TermVar] -> c x y -> c x y
scope vars s = proc t -> do
  env  <- getTermEnv      -< ()
  _    <- deleteTermVars' -< vars
  t'   <- s               -< t
  env' <- getTermEnv      -< ()
  putTermEnv <<< unionTermEnvs -< (vars,env,env')
  returnA -< t'

let_ :: (ArrowApply c, HasStratEnv c) => [(StratVar,Strategy)] -> Strat -> (Strat -> c t t) -> c t t
let_ ss body interp = proc a -> do
  let ss' = [ (v,Closure s' M.empty) | (v,s') <- ss ]
  senv <- readStratEnv -< ()
  localStratEnv (M.union (M.fromList ss') senv) (interp body) -<< a 

96
call :: (ArrowChoice c, ArrowFail () c, ArrowTry c, ArrowPlus c, ArrowApply c,
Sven Keidel's avatar
Sven Keidel committed
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
         IsTermEnv env t c, HasStratEnv c)
     => StratVar
     -> [Strat]
     -> [TermVar]
     -> (Strat -> c t t)
     -> c t t
call f actualStratArgs actualTermArgs interp = proc a -> do
  senv <- readStratEnv -< ()
  case M.lookup f senv of
    Just (Closure (Strategy formalStratArgs formalTermArgs body) senv') -> do
      tenv <- getTermEnv -< ()
      mapA bindTermArg -< zip actualTermArgs formalTermArgs
      let senv'' = bindStratArgs (zip formalStratArgs actualStratArgs)
                                 (if M.null senv' then senv else senv')
      b <- localStratEnv senv'' (interp body) -<< a
      tenv' <- getTermEnv -< ()
      putTermEnv <<< unionTermEnvs -< (formalTermArgs,tenv,tenv')
      returnA -< b
    Nothing -> error (printf "strategy %s not in scope" (show f)) -< ()
  where
    bindTermArg = proc (actual,formal) ->
      lookupTermVar' (proc t -> do insertTerm' -< (formal,t); returnA -< t) failA -<< actual
    {-# INLINE bindTermArg #-}

bindStratArgs :: [(StratVar,Strat)] -> StratEnv -> StratEnv
bindStratArgs [] senv = senv
bindStratArgs ((v,Call v' [] []) : ss) senv =
  case M.lookup v' senv of
    Just s -> M.insert v s (bindStratArgs ss senv)
    _ -> error $ "unknown strategy: " ++ show v'
bindStratArgs ((v,s) : ss) senv =
    M.insert v (Closure (Strategy [] [] s) senv) (bindStratArgs ss senv)
 
match :: (ArrowChoice c, ArrowTry c, ArrowApply c, IsTerm t c, IsTermEnv env t c)
      => c (TermPattern,t) t
match = proc (p,t) -> case p of
  S.As v p2 -> do
    t' <- match -< (S.Var v,t)
    match -< (p2,t')
  S.Var "_" ->
    success -< t
  S.Var x ->
    lookupTermVar'
      (proc t' -> do t'' <- equal -< (t,t'); insertTerm' -< (x,t''); returnA -< t'')
      (proc () -> do insertTerm' -< (x,t); returnA -< t) -<< x
  S.Cons c ts ->
    matchTermAgainstConstructor (zipWithA match) -< (c,ts,t)
  S.Explode c ts ->
    matchTermAgainstExplode
      (proc c' ->  match -< (c,c'))
      (proc ts' -> match -< (ts,ts')) -<< t
  S.StringLiteral s ->
    matchTermAgainstString -< (s,t)
  S.NumberLiteral n ->
    matchTermAgainstNumber -< (n,t)

153
build :: (ArrowChoice c, ArrowFail () c, ArrowTry c, IsTerm t c, IsTermEnv env t c)
Sven Keidel's avatar
Sven Keidel committed
154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169
      => c TermPattern t
build = proc p -> case p of
  S.As _ _ -> error "As-pattern in build is disallowed" -< ()
  S.Var x ->
    lookupTermVar' returnA failA -< x
  S.Cons c ts -> do
    ts' <- mapA build -< ts
    cons -< (c,ts')
  S.Explode c ts -> do
    c'  <- build -< c
    ts' <- build -< ts
    convertFromList -< (c',ts')
  S.NumberLiteral n ->
    numberLiteral -< n
  S.StringLiteral s ->
    stringLiteral -< s