module Control.Arrow.Needle.Parse (
NeedleArrow (..)
, parseNeedle
, NeedleError (..)
, presentNeedleError
) where
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Data.Maybe
import Data.Either
import Data.Monoid
import Text.Parsec as P
import Text.Parsec.Extra (natural)
import Data.Char
import Control.Monad
import Control.Applicative ((<$>), (<*>))
import Control.Monad.State
import Control.Arrow
import Control.Arrow.Needle.Internal.UnevenGrid as G
data NeedleArrow = Input Int Int
| Through (Maybe NeedleArrow) T.Text
| Join [NeedleArrow]
deriving (Show, Read, Eq)
data NeedleElem = None
| Track
| In Int Int
| Out
| LabelIn T.Text
| LabelOut T.Text
| ExtArrow T.Text
| Switch Direction
| TunnelEntrance
| TunnelExit
deriving (Show, Read, Eq)
data NeedleError = ParseError String
| ConstructionError String
instance Show NeedleError where
show = presentNeedleError
presentNeedleError :: NeedleError -> String
presentNeedleError (ParseError s) = "Needle parse error:\n"++s
presentNeedleError (ConstructionError s) = "Needle construction error:\n"++s
data Direction = Up | Down
deriving (Show, Read, Eq)
type NeedleGrid = Grid NeedleElem
parseNeedle :: String -> Either NeedleError NeedleArrow
parseNeedle = parseNeedleGrid >=> gridArrow
gridArrow :: NeedleGrid -> Either NeedleError NeedleArrow
gridArrow grid = do
os <- mapM (arrowToPosition grid) $ outputPositions grid
maybe (Left $ ConstructionError "No outputs") return $ arrowJoin os
outputPositions :: NeedleGrid -> [GridPosition]
outputPositions = findPositions (== Out)
findLabelOutPosition :: T.Text -> GridExamine NeedleElem (Maybe GridPosition)
findLabelOutPosition t = do
grid <- getGrid
return $ listToMaybe (findPositions (== (LabelOut t)) grid)
arrowJoin :: [NeedleArrow] -> Maybe NeedleArrow
arrowJoin [] = Nothing
arrowJoin [a] = Just a
arrowJoin as = Just $ Join as
arrowToPosition :: NeedleGrid -> GridPosition -> Either NeedleError NeedleArrow
arrowToPosition grid pos = gridExamine grid pos go
where
err = return . Left . ConstructionError
success = return . Right
tryPath path = branch $ do
mp <- path
case mp of
Nothing -> err "Nothing on this path"
Just _ -> go
go = do
mh <- hereGet
case mh of
Nothing -> err "Position not in grid"
Just h -> case h of
None -> err "Arrow from nothing"
Track -> do
w <- fromJust <$> width
ups <- forM [0 .. (w 1)] $ \n -> tryPath $ do
e <- lUpGet n
return $ mfilter (== (Switch Down)) e
downs <- forM [0 .. (w 1)] $ \n -> tryPath $ do
e <- lDownGet n
return $ mfilter (== (Switch Up)) e
left <- tryPath leftGet
let paths = rights $ ups ++ [left] ++ downs
mJoint = arrowJoin paths
case mJoint of
Nothing -> do
(n, _) <- G.getPosition
err $ "Track from nowhere on line " ++ show (n + 1)
Just joint -> success joint
In n m -> success $ Input n m
Out -> do
ml <- leftGet
case ml of
Just l -> go
Nothing -> err "An output has no arrow going into it"
LabelIn t -> do
mlo <- findLabelOutPosition t
case mlo of
Just lo -> putPosition lo >> go
Nothing -> err $ "Found label-in '" ++ T.unpack t ++ "' with no label-out"
LabelOut t -> do
ml <- leftGet
case ml of
Just l -> go
Nothing -> err $ "Label-out '" ++ T.unpack t ++ "' has no arrow going into it"
ExtArrow t -> do
left <- tryPath leftGet
up <- tryPath $ do
e <- lUpGet 0
return $ mfilter (== (Switch Down)) e
down <- tryPath $ do
e <- lDownGet 0
return $ mfilter (== (Switch Up)) e
let paths = rights $ [up,left,down]
mJoint = arrowJoin paths
success $ Through mJoint t
Switch d -> do
left <- tryPath leftGet
continuing <- tryPath $ do
e <- case d of
Down -> lUpGet 0
Up -> lDownGet 0
return $ mfilter (== h) e
let paths = rights $ case d of
Down -> [continuing, left]
Up -> [left, continuing]
mJoint = arrowJoin paths
case mJoint of
Nothing -> do
(n, _) <- G.getPosition
err $ "Line switch from nowhere on line " ++ (show n)
Just joint -> success joint
TunnelExit -> do
let tunnel n = if n == 0
then go
else do
ml <- leftGet
case ml of
Nothing -> do
(n,_) <- G.getPosition
err $ "Tunnel from nowhere on line " ++ (show n)
Just TunnelExit -> tunnel (n+1)
Just TunnelEntrance -> tunnel (n1)
Just _ -> tunnel n
tunnel 1
TunnelEntrance -> do
ml <- leftGet
case ml of
Nothing -> do
(n,_) <- G.getPosition
err $ "Tunnel entrance has no arrow going into it on line " ++ (show n)
Just _ -> go
prettyNeedleGrid :: NeedleGrid -> String
prettyNeedleGrid = prettyGrid prettyElem
where
prettyElem None n = replicate n ' '
prettyElem Track n = replicate n '='
prettyElem (In _ _) n = replicate (n1) ' ' ++ "}"
prettyElem Out n = ">" ++ replicate (n1) ' '
prettyElem (LabelIn t) n = replicate (n 1 length s) ' ' ++ s ++ ":"
where
s = T.unpack t
prettyElem (LabelOut t) n = ":" ++ s ++ replicate (n 1 length s) ' '
where
s = T.unpack t
prettyElem (ExtArrow t) n = "{" ++ s ++ replicate (n 2 length s) ' ' ++ "}"
where
s = T.unpack t
prettyElem (Switch Up) n = replicate n '/'
prettyElem (Switch Down) n = replicate n '\\'
prettyElem TunnelEntrance n = replicate n ')'
prettyElem TunnelExit n = replicate n '('
parseNeedleGrid :: String -> Either NeedleError NeedleGrid
parseNeedleGrid s = case result of
Left pe -> Left . ParseError $
"line " ++ (show . sourceLine . errorPos $ pe) ++ ":\n" ++
ls !! ((sourceLine . errorPos $ pe) 1) ++ "\n" ++
replicate ((sourceColumn . errorPos $ pe) 1) ' ' ++ "^"
Right x -> Right (grid x)
where
result = zipWithM parseLine ls [1..]
ls = lines s
parseLine l n = runParser (do
p <- P.getPosition
setPosition $ setSourceLine p n
es <- many (withWidth . choice . map try $ elemParsers n)
optional $ try (string "-- " >> many anyChar)
eof
return es) 0 "needle expression" l
withWidth p = do
c1 <- sourceColumn <$> P.getPosition
x <- p
c2 <- sourceColumn <$> P.getPosition
return (x, c2 c1)
elemParsers n = [
do
many1 space
return None
, do
many1 (char '=')
return Track
, do
void (char '}')
m <- getState
modifyState (+1)
return $ In n m
, do
void (char '>')
return Out
, do
l <- many1 letter
spaces
void (char ':')
return $ LabelIn (T.pack l)
, do
void (char ':')
spaces
l <- many1 letter
return $ LabelOut (T.pack l)
, do
void (char '{')
f <- anyChar
l <- manyTill anyChar (char '}')
return $ ExtArrow (T.pack $ f : l)
, do
void (char '/')
return $ Switch Up
, do
void (char '\\')
return $ Switch Down
, do
void (char ')')
return TunnelEntrance
, do
void (char '(')
return TunnelExit
]