module Term where
import qualified ModuleBase as Module
import qualified TermParser as Parser
import TermParser
( lexer, symbol, operators,
operatorSymbols, operatorStart, operatorLetter )
import SourceText
( ModuleRange(ModuleRange), emptyRange,
ParserRange, consRange, ranged )
import InOut ( Input, Output, input, output )
import qualified Text.ParserCombinators.Parsec.Token as T
import qualified Text.ParserCombinators.Parsec.Expr as Expr
import qualified Text.ParserCombinators.Parsec as Parsec
import Text.ParserCombinators.Parsec.Expr ( Assoc )
import Text.ParserCombinators.Parsec ( Parser, getPosition, (<|>), (<?>), )
import Text.PrettyPrint.HughesPJ ( Doc, (<+>), fsep, parens, render, text )
import qualified Control.Monad.Exception.Synchronous as ME
import Control.Monad.Exception.Synchronous ( Exceptional(Exception) )
import Control.Monad.Fail ( MonadFail )
import Control.Monad ( liftM2, mzero )
import Control.Applicative ( (<$>) )
import Data.Char (isUpper, isLower)
data Identifier range = Identifier { range :: range, name :: String }
instance Functor Identifier where
fmap f (Identifier rng idname) = Identifier (f rng) idname
identifier :: Module.Name -> String -> Identifier ModuleRange
identifier moduName =
Identifier (ModuleRange moduName Module.noVersion emptyRange)
isConstructor :: Identifier range -> Bool
isConstructor i =
case name i of
c:_ -> c == '[' || c == ':' || isUpper c
_ -> error "isConstructor: identifier must be non-empty"
isVariable :: Identifier range -> Bool
isVariable i =
case name i of
c:_ -> isLower c || elem c ('_':operatorSymbols)
_ -> error "isVariable: identifier must be non-empty"
parenOperator :: (ParserRange range) => Parser (Identifier range)
parenOperator =
T.parens lexer $ T.lexeme lexer $
fmap (uncurry Identifier) $ ranged $
liftM2 (:) operatorStart (Parsec.many operatorLetter)
infixOperator :: (ParserRange range) => Parser (Identifier range)
infixOperator =
T.lexeme lexer $
fmap (uncurry Identifier) $ ranged $
Parsec.between (Parsec.char '`') (Parsec.char '`') Parser.identifier
<|>
liftM2 (:) operatorStart (Parsec.many operatorLetter)
instance (ParserRange range) => Input (Identifier range) where
input =
T.lexeme lexer $
fmap (uncurry Identifier) $ ranged Parser.identifier
instance Output (Identifier range) where
output i = text $ name i
instance Show (Identifier range) where show = render . output
data Term range =
Node (Identifier range) [ Term range ]
| Number range Integer
| StringLiteral range String
instance Show (Term range) where show = render . output
match :: Term range -> Term range -> Bool
match (Node x xs) (Node y ys) = name x == name y && equatingList match xs ys
match (Number _rngx x) (Number _rngy y) = x==y
match (StringLiteral _rngx x) (StringLiteral _rngy y) = x==y
match _ _ = False
equatingList :: (a -> a -> Bool) -> [a] -> [a] -> Bool
equatingList eq =
let go (x:xs) (y:ys) = eq x y && go xs ys
go [] [] = True
go _ _ = False
in go
variable :: Module.Name -> String -> Term ModuleRange
variable moduName n = Node (identifier moduName n) []
main :: Term ModuleRange
main = variable Module.mainName "main"
{- |
simplifies case analysis
-}
viewNode :: Term range -> Maybe (String, [Term range])
viewNode (Node f xs) = Just (Term.name f, xs)
viewNode _ = Nothing
liftMonadFail :: (MonadFail m) => Exceptional String a -> m a
liftMonadFail = ME.switch fail return
{- |
This function allows us to handle @((f) a) b@ equivalently to @f a b@
in any circumstance, i.e. parsing and rewriting.
-}
appendArguments :: Term range -> [Term range] -> Exceptional String (Term range)
appendArguments g ys =
case (g, ys) of
(Node f xs, _) -> return $ Node f $ xs ++ ys
(t, []) -> return t
(t, _) ->
Exception $
unwords [ "cannot apply ", show t,
"to arguments like a function" ]
{- |
I would like to use 'T.stringLiteral'
but this skips trailing spaces
and we need the precise range of the literal.
However this implementation is very simplistic,
since T.stringChar is not exported.
-}
parseStringLiteral :: Parsec.Parser String
parseStringLiteral =
flip (<?>) "literal string" $
-- fmap catMaybes $
Parsec.between
(Parsec.char '"')
(Parsec.char '"' <?> "end of string")
(Parsec.many (Parsec.noneOf $ '"':"\n\r\\"))
-- (Parsec.many (T.stringChar lexer))
parseAtom :: (ParserRange range) => Parser (Term range)
parseAtom =
(T.lexeme lexer $ fmap (uncurry Number) $
ranged (fmap read $ Parsec.many1 Parsec.digit))
<|> fmap (uncurry StringLiteral)
(T.lexeme lexer (ranged parseStringLiteral))
-- <|> fmap (uncurry StringLiteral) (ranged (T.stringLiteral lexer))
<|> T.parens lexer input
<|> bracketedList
<|> fmap (flip Node []) input
parse :: (ParserRange range) => Parser (Term range)
parse =
liftMonadFail =<<
liftM2 appendArguments parseAtom (Parsec.many parseAtom)
instance (ParserRange range) => Input (Term range) where
input = Expr.buildExpressionParser table parse
table :: (ParserRange range) => Expr.OperatorTable Char st (Term range)
table = map ( map binary ) operators
binary ::
(ParserRange range) => (String, Assoc) -> Expr.Operator Char st (Term range)
binary (s, assoc) = flip Expr.Infix assoc $ do
rng <- Parsec.try $ T.lexeme lexer $ do
(rng,_) <- ranged $ Parsec.string s
Parsec.notFollowedBy operatorLetter <?> ("end of " ++ show s)
return rng
return $ \ l r -> Node ( Identifier { name = s, range = rng } ) [ l, r ]
bracketedList :: (ParserRange range) => Parser (Term range)
bracketedList = do
(r,_) <- ranged $ symbol "["
insideBracketedList r
insideBracketedList :: (ParserRange range) => range -> Parser (Term range)
insideBracketedList rng =
do (r,_) <- ranged $ symbol "]"
return $ Node ( Identifier { name = "[]", range = r } ) []
<|> do x <- input
q <- getPosition
xs <- do symbol "]" ; r <- getPosition
return $ Node
( Identifier { name = "[]", range = consRange q r } ) []
<|> do symbol "," ; r <- getPosition
insideBracketedList $ consRange q r
return $ Node ( Identifier { name = ":", range = rng } ) [ x, xs ]
instance Output (Term range) where
output t = case t of
Number _ n -> text $ show n
StringLiteral _ s -> text $ show s
Node f args -> output f <+> fsep ( map protected args )
protected :: Term range -> Doc
protected t = case t of
Node _f (_:_) -> parens $ output t
_ -> output t
termRange :: Term range -> range
termRange (Node i _) = range i
termRange (Number rng _) = rng
termRange (StringLiteral rng _) = rng
instance Functor Term where
fmap f t =
case t of
Node i ts -> Node (f <$> i) (map (fmap f) ts)
Number rng n -> Number (f rng) n
StringLiteral rng str -> StringLiteral (f rng) str
{- |
compute the number of nodes in the same depth
-}
breadths :: Term range -> [ Int ]
breadths t = 1 : case t of
Node _f xs -> foldl addList [] $ map breadths xs
_ -> []
addList :: [ Int ] -> [ Int ] -> [ Int ]
addList (x:xs) (y:ys) = (x+y) : addList xs ys
addList [] ys = ys
addList xs [] = xs
type Position = [ Int ]
subterms :: Term range -> [ (Position, Term range) ]
subterms t = ( [], t ) : case t of
Node _f xs -> do
(k, x) <- zip [ 0.. ] xs
(p, s) <- subterms x
return (k : p, s)
_ -> []
peek :: Term range -> Position -> Maybe (Term range)
peek t [] = return t
peek (Node _f xs) (k : ks) =
case drop k xs of
x:_ -> peek x ks
[] -> mzero
peek _ _ = mzero
poke :: Term range -> Position -> Term range -> Maybe (Term range)
poke _t [] s = return s
poke (Node f xs) (k : ks) s =
case splitAt k xs of
(pre, x : post) -> do
y <- poke x ks s
return $ Node f $ pre ++ y : post
(_, []) -> error "Term.poke: index too large"
poke _ (_:_) _ =
error "Term.poke: cannot access a leaf with an index"