camfort-0.700: source-generic.hs
{-
Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import Text.Parsec.Char
import qualified Text.ParserCombinators.Parsec.Token
import Data.Maybe
import Data.Data
import Data.Generics.Zipper
import Debug.Trace
import Control.Comonad
data Expr a = Plus a (Expr a) (Expr a) | Num a Int deriving (Show, Data, Typeable)
instance Comonad Expr where
extract (Plus x _ _) = x
extract (Num x _) = x
tagRoot :: Expr a -> a -> Expr a
tagRoot (Plus _ e1 e2) x = Plus x e1 e2
tagRoot (Num _ n) x = Num x n
instance Functor Expr where
fmap f (Plus x e1 e2) = Plus (f x) (fmap f e1) (fmap f e2)
fmap f (Num x n) = Num (f x) n
flipFlag (ps, flag) = (ps, not flag)
insertP :: Zipper (Expr Annotation) -> (Expr Annotation) -> Zipper (Expr Annotation)
insertP z e' = let e = ((fromJust . getHole $ z) :: Expr Annotation)
in setHole (tagRoot e' (flipFlag $ extract e)) z
type Annotation = (((Line, Column), (Line, Column)), Bool)
tagPos p = do pos <- getPosition
x <- p
pos' <- getPosition
return $ tagRoot x ((((sourceLine pos, sourceColumn pos),
(sourceLine pos', sourceColumn pos')), False))
expr = tagPos $ (try exprNum) <|> exprPlus
exprPlus = do string "("
spaces
e1 <- expr
spaces
string "+"
spaces
e2 <- expr
spaces
string ")"
return $ Plus undefined e1 e2
exprNum = do n <- many1 digit
return $ Num undefined (read n)
--
doParse :: String -> Expr Annotation
doParse input = let p = do { e <- expr; eof; return e }
in case (runParser p () "" input) of
Left err -> error (show err)
Right x -> x
ppr (Plus _ e1 e2) = "(" ++ ppr e1 ++ " + " ++ ppr e2 ++ ")"
ppr (Num _ n) = show n
maybeC :: (b -> Maybe b) -> b -> b
maybeC f x = case (f x) of Nothing -> x
Just x' -> x'
upF = maybeC up
leftNode x = fromJust $ down' x >>= right
rightNode x = fromJust $ down x
rightNode' x = fromJust $ down' x >>= right >>= right
getExpr z = (fromJust $ getHole $ z)::(Expr Annotation)
getBounds z = fst $ extract $ ((fromJust $ getHole $ z)::(Expr Annotation))
pprint input z = pprint' (1, 1) (lines input) z
pprint' :: (Int, Int) -> [String] -> Zipper (Expr Annotation) -> String
pprint' (l, c) [] _ = ""
pprint' (l, c) ([]:[]) z = ""
pprint' (l, c) ([]:xs) z = pprint' (l+1, 0) xs z ++ "\n"
pprint' (l, c) inp z
| inBounds (l, c) (getBounds z) =
let e = fromJust $ getHole z
in if (snd $ extract e) then ppr e
else
case e of
Num ((lb, ub), _) _ -> fst $ takeBounds (lb, ub) inp
Plus ((lb, ub), _) _ _ ->
let lfb = getBounds (leftNode z)
rfb = getBounds (rightNode z)
(p1, rest1) = takeBounds (lb, fst $ lfb) inp
p2 = pprint' (fst $ lfb) rest1 (leftNode z)
(_, inp') = takeBounds (fst $ lfb, snd $ lfb) rest1
(p3, rest2) = takeBounds (snd $ lfb, fst $ rfb) inp'
p4 = pprint' (fst $ rfb) rest2 (rightNode z)
(_, inp'') = takeBounds (fst $ rfb, snd $ rfb) rest2
(p5, rest3) = takeBounds (snd $ rfb, ub) inp''
in p1 ++ p2 ++ p3 ++ p4 ++ p5
| otherwise = pprint' (l, c) inp (upF z) -- go up the tree if current position is not within the root node
inBounds x (l, u) = x >= l && x < u
takeBounds ((ll, lc), (ul, uc)) inp = takeBounds' ((ll, lc), (ul, uc)) [] inp
takeBounds' ((ll, lc), (ul, uc)) tk inp =
if (ll == ul && lc == uc) then (reverse tk, inp)
else case inp of [] -> (reverse tk, inp)
([]:ys) -> takeBounds' ((ll+1, 0), (ul, uc)) ('\n':tk) ys
((x:xs):ys) -> takeBounds' ((ll, lc+1), (ul, uc)) (x:tk) (xs:ys)
reprint :: String -> Zipper (Expr Annotation) -> String
reprint input z = reprintP (1, 1) (lines input) z
reprintP :: (Line, Column) -> [String] -> Zipper (Expr Annotation) -> String
reprintP cursor inp z = case getHole z of
Just e ->
let ((lb, ub), flag) = extract e
in if inBounds cursor (lb, ub) then
if flag then ppr e
else case down' z of
Just cz -> reprintR cursor ub inp cz
Nothing -> ""
else maybe "" (reprintP cursor inp) (up z)
Nothing -> ""
reprintR :: (Line, Column) -> (Line, Column) -> [String] -> Zipper (Expr Annotation) -> String
reprintR cursor parentUb inp z = case (getHole z)::(Maybe (Expr Annotation)) of
Just e ->
let ((lb, ub), _) = extract e
(p1, rest1) = takeBounds (cursor, lb) inp
p2 = reprintP lb rest1 z
inp' = snd $ takeBounds (lb, ub) rest1
in p1 ++ p2 ++ case right z of
Just rz -> reprintR ub parentUb inp' rz
Nothing -> fst $ takeBounds (ub, parentUb) inp'
Nothing -> case right z of
Just rz -> reprintR cursor parentUb inp rz
Nothing -> fst $ takeBounds (cursor, parentUb) inp
type SrcLoc = (Line, Column)
reprintD :: String -> Zipper (Expr Annotation) -> String
reprintD input z = let input' = lines input
in reprintA (1, 1) (length input', 1 + (length $ last input')) input' z
doHole :: SrcLoc -> [String] -> Zipper (d Annotation) -> (String, SrcLoc)
doHole cursor inp z = case (getHole z)::(Maybe (Expr Annotation)) of
Just e -> let ((lb, ub), flag) = extract e
(p1, rest1) = takeBounds (cursor, lb) inp
in if flag then (p1 ++ ppr e, ub)
else case (down' z) of
Just cz -> (p1 ++ reprintA lb ub rest1 cz, ub)
Nothing -> let (p2, _) = takeBounds (lb, ub) rest1
in (p1, ub)
Nothing -> case (down' z) of
Just cz -> (reprintA cursor cursor inp cz, cursor)
Nothing -> ("", cursor)
reprintA :: SrcLoc -> SrcLoc -> [String] -> Zipper (d Annotation) -> String
reprintA cursor end inp z = let (p1, cursor') = doHole cursor inp z
(p2, inp') = takeBounds (cursor, cursor') inp
in p1 ++ case (right z) of
Just rz -> reprintA cursor' end inp' rz
Nothing -> fst $ takeBounds (cursor', end) inp'
x = let input = "((1 + 2) + 3 )" in (toZipper (doParse input))::(Zipper (Expr Annotation))
fooN = let input = "(1 + 2)"
z = toZipper (doParse input)
in ((getHole z)::(Maybe (Expr Annotation)), reprint input z)
foo = let input = "(( 1 + 2) + 3 )"
x = (toZipper (doParse input))::(Zipper (Expr Annotation))
x' = rightNode x
y = doParse "(3 + 4)"
z = insertP x' y
w = doParse "(9 + (4 + 3))"
z' = insertP (rightNode $ leftNode $ upF $ z) w
z'' = upF $ upF $ z'
in (reprint input z', reprintD input z'', pprint input z') -- , maybe False (const True) (down' x >>= down' >>= down' >>= down' >>= down'))
-- case ((down' z'') >>= right) of
-- Nothing -> "nothing"
-- Just a -> show $ getExpr a -- reprint' input z'' -- pprint input z'