github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-22 14:21:31 +03:00
Code Issues Projects Releases Wiki Activity

Maintain call-stacks.

Browse Source
This commit is contained in:
Rob Rix 2017-03-10 13:12:05 -05:00
parent a8222cf0d8
commit 91694c4999
1 changed files with 11 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
src/SES/Myers.hs
View File

@ -1,9 +1,10 @@
{-# LANGUAGE GADTs, MultiParamTypeClasses #-} {-# LANGUAGE GADTs, ImplicitParams, MultiParamTypeClasses #-}
module SES.Myers where module SES.Myers where
import Control.Monad.Free.Freer import Control.Monad.Free.Freer
import Data.These import Data.These
import qualified Data.Vector as Vector import qualified Data.Vector as Vector
import GHC.Stack
import Prologue hiding (for, State) import Prologue hiding (for, State)
data MyersF element result where data MyersF element result where
@ -34,14 +35,14 @@ data Direction = Forward | Reverse
-- Evaluation -- Evaluation
runMyers :: (a -> a -> Bool) -> Myers a b -> b runMyers :: HasCallStack => (a -> a -> Bool) -> Myers a b -> b
runMyers eq = runAll $ MyersState (Vector.replicate 100 0) (Vector.replicate 100 0) runMyers eq = runAll $ MyersState (Vector.replicate 100 0) (Vector.replicate 100 0)
where runAll state step = case runMyersStep eq state step of where runAll state step = case runMyersStep eq state step of
Left a -> a Left a -> a
Right next -> uncurry runAll next Right next -> uncurry runAll next
runMyersStep :: (a -> a -> Bool) -> MyersState -> Myers a b -> Either b (MyersState, Myers a b) runMyersStep :: HasCallStack => (a -> a -> Bool) -> MyersState -> Myers a b -> Either b (MyersState, Myers a b)
runMyersStep eq state step = case step of runMyersStep eq state step = let ?callStack = popCallStack callStack in case step of
Return a -> Left a Return a -> Left a
Then step cont -> case step of Then step cont -> case step of
M myers -> Right (state, decompose myers >>= cont) M myers -> Right (state, decompose myers >>= cont)
@ -52,8 +53,8 @@ runMyersStep eq state step = case step of
GetEq -> Right (state, cont eq) GetEq -> Right (state, cont eq)
decompose :: MyersF a b -> Myers a b decompose :: HasCallStack => MyersF a b -> Myers a b
decompose myers = case myers of decompose myers = let ?callStack = popCallStack callStack in case myers of
LCS graph LCS graph
| null (as graph) || null (bs graph) -> return [] | null (as graph) || null (bs graph) -> return []
| otherwise -> do | otherwise -> do
@ -122,16 +123,16 @@ decompose myers = case myers of
-- Smart constructors -- Smart constructors
lcs :: EditGraph a -> Myers a [a] lcs :: HasCallStack => EditGraph a -> Myers a [a]
lcs graph = M (LCS graph) `Then` return lcs graph = M (LCS graph) `Then` return
findDPath :: EditGraph a -> Direction -> EditDistance -> Diagonal -> Myers a Endpoint findDPath :: HasCallStack => EditGraph a -> Direction -> EditDistance -> Diagonal -> Myers a Endpoint
findDPath graph direction d k = M (FindDPath graph direction d k) `Then` return findDPath graph direction d k = M (FindDPath graph direction d k) `Then` return
middleSnake :: EditGraph a -> Myers a (Snake, EditDistance) middleSnake :: HasCallStack => EditGraph a -> Myers a (Snake, EditDistance)
middleSnake graph = M (MiddleSnake graph) `Then` return middleSnake graph = M (MiddleSnake graph) `Then` return
getEq :: Myers a (a -> a -> Bool) getEq :: HasCallStack => Myers a (a -> a -> Bool)
getEq = GetEq `Then` return getEq = GetEq `Then` return