module Yi.Syntax.Haskell ( PModule
, PModuleDecl
, PImport
, Exp (..)
, Tree
, parse
, indentScanner
) where
import Control.Applicative
import Data.Foldable hiding (elem, notElem)
import Data.Maybe
import Data.List ((\\))
import Yi.IncrementalParse
import Yi.Lexer.Alex
import Yi.Lexer.Haskell
import Yi.Syntax.Layout
import Yi.Syntax.Tree
import Yi.Syntax
import Control.Arrow ((&&&))
indentScanner :: Scanner (AlexState lexState) TT
-> Scanner (Yi.Syntax.Layout.State Token lexState) TT
indentScanner = layoutHandler startsLayout [(Special '(', Special ')'),
(Reserved Let, Reserved In),
(Special '[', Special ']'),
(Special '{', Special '}')]
ignoredToken
(Special '<', Special '>', Special '.')
isBrace
isBrace :: TT -> Bool
isBrace (Tok br _ _) = Special '{' == br
ignoredToken :: TT -> Bool
ignoredToken (Tok t _ (Posn{})) = isComment t || t == CppDirective
type Tree = PModule
type PAtom = Exp
type Block = Exp
type PGuard = Exp
type PModule = Exp
type PModuleDecl = Exp
type PImport = Exp
data Exp t
= PModule { comments :: [t]
, progMod :: Maybe (PModule t)
}
| ProgMod { modDecl :: PModuleDecl t
, body :: PModule t
}
| Body { imports :: Exp t
, content :: Block t
, extraContent :: Block t
}
| PModuleDecl { moduleKeyword :: PAtom t
, name :: PAtom t
, exports :: Exp t
, whereKeyword :: Exp t
}
| PImport { importKeyword :: PAtom t
, qual :: Exp t
, name' :: PAtom t
, as :: Exp t
, specification :: Exp t
}
| TS t [Exp t]
| PType { typeKeyword :: PAtom t
, typeCons :: Exp t
, equal :: PAtom t
, btype :: Exp t
}
| PData { dataKeyword :: PAtom t
, dtypeCons :: Exp t
, dEqual :: Exp t
, dataRhs :: Exp t
}
| PData' { dEqual :: PAtom t
, dataCons :: Exp t
}
| PClass { cKeyword :: PAtom t
, cHead :: Exp t
, cwhere :: Exp t
}
| Paren (PAtom t) [Exp t] (PAtom t)
| Block [Exp t]
| PAtom t [t]
| Expr [Exp t]
| PWhere (PAtom t) (Exp t) (Exp t)
| Bin (Exp t) (Exp t)
| PError { errorTok :: t
, marker :: t
, commentList :: [t]
}
| RHS (PAtom t) (Exp t)
| Opt (Maybe (Exp t))
| Modid t [t]
| Context (Exp t) (Exp t) (PAtom t)
| PGuard [PGuard t]
| PGuard' (PAtom t) (Exp t) (PAtom t)
| TC (Exp t)
| DC (Exp t)
| PLet (PAtom t) (Exp t) (Exp t)
| PIn t [Exp t]
deriving (Show, Foldable)
instance IsTree Exp where
emptyNode = Expr []
uniplate tree = case tree of
(ProgMod a b) -> ([a,b], \[a,b] -> ProgMod a b)
(Body x exp exp') -> ([x, exp, exp'], \[x, exp, exp'] -> Body x exp exp')
(PModule x (Just e)) -> ([e],\[e] -> PModule x (Just e))
(Paren l g r) ->
(l:g ++ [r], \(l:gr) -> Paren l (init gr) (last gr))
(RHS l g) -> ([l,g],\[l,g] -> (RHS l g))
(Block s) -> (s,Block)
(PLet l s i) -> ([l,s,i],\[l,s,i] -> PLet l s i)
(PIn x ts) -> (ts,PIn x)
(Expr a) -> (a,Expr)
(PClass a b c) -> ([a,b,c],\[a,b,c] -> PClass a b c)
(PWhere a b c) -> ([a,b,c],\[a,b,c] -> PWhere a b c)
(Opt (Just x)) -> ([x],\[x] -> (Opt (Just x)))
(Bin a b) -> ([a,b],\[a,b] -> (Bin a b))
(PType a b c d) -> ([a,b,c,d],\[a,b,c,d] -> PType a b c d)
(PData a b c d) -> ([a,b,c,d],\[a,b,c,d] -> PData a b c d)
(PData' a b) -> ([a,b] ,\[a,b] -> PData' a b)
(Context a b c) -> ([a,b,c],\[a,b,c] -> Context a b c)
(PGuard xs) -> (xs,PGuard)
(PGuard' a b c) -> ([a,b,c],\[a,b,c] -> PGuard' a b c)
(TC e) -> ([e],\[e] -> TC e)
(DC e) -> ([e],\[e] -> DC e)
PModuleDecl a b c d -> ([a,b,c,d],\[a,b,c,d] -> PModuleDecl a b c d)
PImport a b c d e -> ([a,b,c,d,e],\[a,b,c,d,e] -> PImport a b c d e)
t -> ([],const t)
parse :: P TT (Tree TT)
parse = pModule <* eof
pModule :: Parser TT (PModule TT)
pModule = PModule <$> pComments <*> optional
(pBlockOf' (ProgMod <$> pModuleDecl
<*> pModBody <|> pBody))
pModBody :: Parser TT (PModule TT)
pModBody = (exact [startBlock] *>
(Body <$> pImports
<*> ((pTestTok elems *> pBod)
<|> pEmptyBL) <* exact [endBlock]
<*> pBod
<|> Body <$> noImports
<*> ((pBod <|> pEmptyBL) <* exact [endBlock])
<*> pBod))
<|> (exact [nextLine] *> pBody)
<|> Body <$> pure emptyNode <*> pEmptyBL <*> pEmptyBL
where pBod = Block <$> pBlocks pTopDecl
elems = [Special ';', nextLine, startBlock]
pEmptyBL :: Parser TT (Exp TT)
pEmptyBL = Block <$> pEmpty
pBody :: Parser TT (PModule TT)
pBody = Body <$> noImports <*> (Block <$> pBlocks pTopDecl) <*> pEmptyBL
<|> Body <$> pImports <*> ((pTestTok elems *> (Block <$> pBlocks pTopDecl))
<|> pEmptyBL) <*> pEmptyBL
where elems = [nextLine, startBlock]
noImports :: Parser TT (Exp TT)
noImports = notNext [Reserved Import] *> pure emptyNode
where notNext f = testNext $ uncurry (||) . (&&&) isNothing
(flip notElem f . tokT . fromJust)
pVarId :: Parser TT (Exp TT)
pVarId = pAtom [VarIdent, Reserved Other, Reserved As]
pQvarid :: Parser TT (Exp TT)
pQvarid = pAtom [VarIdent, ConsIdent, Reserved Other, Reserved As]
pQvarsym :: Parser TT (Exp TT)
pQvarsym = pParen ((:) <$> please (PAtom <$> sym isOperator <*> pComments)
<*> pEmpty)
isOperator :: Token -> Bool
isOperator (Operator _) = True
isOperator (ReservedOp _) = True
isOperator (ConsOperator _) = True
isOperator _ = False
pQtycon :: Parser TT (Exp TT)
pQtycon = pAtom [ConsIdent]
pVars :: Parser TT (Exp TT)
pVars = pMany pVarId
nextLine :: Token
nextLine = Special '.'
startBlock :: Token
startBlock = Special '<'
endBlock :: Token
endBlock = Special '>'
pEmpty :: Applicative f => f [a]
pEmpty = pure []
pToList :: Applicative f => f a -> f [a]
pToList = (box <$>)
where box x = [x]
sym :: (Token -> Bool) -> Parser TT TT
sym f = symbol (f . tokT)
exact :: [Token] -> Parser TT TT
exact = sym . flip elem
please :: Parser TT (Exp TT) -> Parser TT (Exp TT)
please = (<|>) (PError <$> recoverWith errTok
<*> errTok
<*> pEmpty)
pErr :: Parser TT (Exp TT)
pErr = PError <$> recoverWith (sym $ not . uncurry (||) . (&&&) isComment
(== CppDirective))
<*> errTok
<*> pComments
ppCons :: Parser TT (Exp TT)
ppCons = ppAtom [ConsIdent]
pKW :: [Token] -> Parser TT (Exp TT) -> Parser TT (Exp TT)
pKW k r = Bin <$> pAtom k <*> r
pOP :: [Token] -> Parser TT (Exp TT) -> Parser TT (Exp TT)
pOP op r = Bin <$> pAtom op <*> r
pComments :: Parser TT [TT]
pComments = many $ sym $ uncurry (||) . (&&&) isComment (== CppDirective)
pOpt :: Parser TT (Exp TT) -> Parser TT (Exp TT)
pOpt x = Opt <$> optional x
pAtom, ppAtom :: [Token] -> Parser TT (Exp TT)
pAtom = flip pCAtom pComments
ppAtom at = pAtom at <|> recoverAtom
recoverAtom :: Parser TT (Exp TT)
recoverAtom = PAtom <$> recoverWith errTok <*> pEmpty
pCAtom :: [Token] -> Parser TT [TT] -> Parser TT (Exp TT)
pCAtom r c = PAtom <$> exact r <*> c
pBareAtom a = pCAtom a pEmpty
pSepBy :: Parser TT (Exp TT) -> Parser TT (Exp TT) -> Parser TT [Exp TT]
pSepBy p sep = pEmpty
<|> (:) <$> p <*> (pSepBy1 p sep <|> pEmpty)
<|> pToList sep
where pSepBy1 r p' = (:) <$> p' <*> (pEmpty <|> pSepBy1 p' r)
pParenSep :: Parser TT (Exp TT) -> Parser TT (Exp TT)
pParenSep = pParen . flip pSepBy pComma
pComma :: Parser TT (Exp TT)
pComma = pAtom [Special ',']
pModuleDecl :: Parser TT (PModuleDecl TT)
pModuleDecl = PModuleDecl <$> pAtom [Reserved Module]
<*> ppAtom [ConsIdent]
<*> pOpt (pParenSep pExport)
<*> (optional (exact [nextLine]) *>
(Bin <$> ppAtom [Reserved Where])
<*> pMany pErr) <* pTestTok elems
where elems = [nextLine, startBlock, endBlock]
pExport :: Parser TT (Exp TT)
pExport = optional (exact [nextLine]) *> please
( pVarId
<|> pEModule
<|> Bin <$> pQvarsym <*> (DC <$> pOpt expSpec)
<|> Bin <$> (TC <$> pQtycon) <*> (DC <$> pOpt expSpec)
)
where expSpec = pParen (pToList (please (pAtom [ReservedOp DoubleDot]))
<|> pSepBy pQvarid pComma)
pTestTok :: [Token] -> Parser TT ()
pTestTok f = testNext (uncurry (||) . (&&&) isNothing
(flip elem f . tokT . fromJust))
pImports :: Parser TT (Exp TT)
pImports = Expr <$> many (pImport
<* pTestTok pEol
<* optional (some $ exact [nextLine, Special ';']))
where pEol = [Special ';', nextLine, endBlock]
pImport :: Parser TT (PImport TT)
pImport = PImport <$> pAtom [Reserved Import]
<*> pOpt (pAtom [Reserved Qualified])
<*> ppAtom [ConsIdent]
<*> pOpt (pKW [Reserved As] ppCons)
<*> (TC <$> pImpSpec)
where pImpSpec = Bin <$> pKW [Reserved Hiding]
(please pImpS) <*> pMany pErr
<|> Bin <$> pImpS <*> pMany pErr
<|> pMany pErr
pImpS = DC <$> pParenSep pExp'
pExp' = Bin
<$> (PAtom <$> sym
(uncurry (||) . (&&&)
(`elem` [VarIdent, ConsIdent])
isOperator) <*> pComments
<|> pQvarsym)
<*> pOpt pImpS
pType :: Parser TT (Exp TT)
pType = PType <$> (Bin <$> pAtom [Reserved Type]
<*> pOpt (pAtom [Reserved Instance]))
<*> (TC . Expr <$> pTypeExpr')
<*> ppAtom [ReservedOp Equal]
<*> (TC . Expr <$> pTypeExpr')
pData :: Parser TT (Exp TT)
pData = PData <$> pAtom [Reserved Data, Reserved NewType]
<*> (TC . Expr <$> pTypeExpr')
<*> pOpt (pDataRHS <|> pGadt)
<*> pOpt pDeriving
pGadt :: Parser TT (Exp TT)
pGadt = pWhere pTypeDecl
pDataRHS :: Parser TT (Exp TT)
pDataRHS = PData' <$> pAtom [ReservedOp Equal] <*> pConstrs
pDeriving :: Parser TT (Exp TT)
pDeriving = pKW [Reserved Deriving] (TC . Expr <$> pTypeExpr')
pAtype :: Parser TT (Exp TT)
pAtype = pAtype'
<|> pErr
pAtype' :: Parser TT (Exp TT)
pAtype' = pTypeCons
<|> pParen (many $ pExprElem [])
<|> pBrack (many $ pExprElem [])
pTypeCons :: Parser TT (Exp TT)
pTypeCons = Bin <$> pAtom [ConsIdent]
<*> please (pMany $ pAtom [VarIdent, ConsIdent])
pContext :: Parser TT (Exp TT)
pContext = Context <$> pOpt pForAll
<*> (TC <$> (pClass' <|> pParenSep pClass'))
<*> ppAtom [ReservedOp DoubleRightArrow]
where pClass' :: Parser TT (Exp TT)
pClass' = Bin <$> pQtycon
<*> (please pVarId
<|> pParen ((:) <$> please pVarId
<*> many pAtype'))
pForAll :: Parser TT (Exp TT)
pForAll = pKW [Reserved Forall]
(Bin <$> pVars <*> ppAtom [Operator "."])
pConstrs :: Parser TT (Exp TT)
pConstrs = Bin <$> (Bin <$> pOpt pContext <*> pConstr)
<*> pMany (pOP [ReservedOp Pipe]
(Bin <$> pOpt pContext <*> please pConstr))
pConstr :: Parser TT (Exp TT)
pConstr = Bin <$> pOpt pForAll
<*> (Bin <$>
(Bin <$> (DC <$> pAtype) <*>
(TC <$> pMany (strictF pAtype))) <*> pOpt st)
<|> Bin <$> lrHs <*> pMany (strictF pAtype)
<|> pErr
where lrHs = pOP [Operator "!"] pAtype
st = pEBrace (pTypeDecl `sepBy1` pBareAtom [Special ','])
strictF :: Parser TT (Exp TT) -> Parser TT (Exp TT)
strictF a = Bin <$> pOpt (pAtom [Operator "!"]) <*> a
pEModule ::Parser TT (Exp TT)
pEModule = pKW [Reserved Module]
$ please (Modid <$> exact [ConsIdent] <*> pComments)
pLet :: Parser TT (Exp TT)
pLet = PLet <$> pAtom [Reserved Let]
<*> pBlock pFunDecl
<*> pOpt (pBareAtom [Reserved In])
pDo :: Parser TT (Exp TT)
pDo = Bin <$> pAtom [Reserved Do]
<*> pBlock (pExpr ((Special ';' : recognizedSometimes)
\\ [ReservedOp LeftArrow]))
pLambda :: Parser TT (Exp TT)
pLambda = Bin <$> pAtom [ReservedOp BackSlash]
<*> (Bin <$> (Expr <$> pPattern)
<*> please (pBareAtom [ReservedOp RightArrow]))
pOf :: Parser TT (Exp TT)
pOf = Bin <$> pAtom [Reserved Of]
<*> pBlock pAlternative
pAlternative = Bin <$> (Expr <$> pPattern)
<*> please (pFunRHS (ReservedOp RightArrow))
pClass :: Parser TT (Exp TT)
pClass = PClass <$> pAtom [Reserved Class, Reserved Instance]
<*> (TC . Expr <$> pTypeExpr')
<*> pOpt (please (pWhere pTopDecl))
pGuard :: Token -> Parser TT (Exp TT)
pGuard equalSign = PGuard
<$> some (PGuard' <$> pCAtom [ReservedOp Pipe] pEmpty <*>
pExpr (recognizedSometimes
\\ [ReservedOp LeftArrow, Special ','])
<*> please (pEq equalSign))
pFunRHS :: Token -> Parser TT (Exp TT)
pFunRHS equalSign =
Bin <$> (pGuard equalSign <|> pEq equalSign) <*> pOpt (pWhere pFunDecl)
pWhere :: Parser TT (Exp TT) -> Parser TT (Exp TT)
pWhere p =
PWhere <$> pAtom [Reserved Where] <*> please (pBlock p) <*> pMany pErr
pDecl :: Bool -> Bool -> Parser TT (Exp TT)
pDecl acceptType acceptEqu =
Expr <$> ((Yuck $
Enter "missing end of type or equation declaration" $ pure [])
<|> ((:) <$> pElem False recognizedSometimes
<*> pToList (pDecl acceptType acceptEqu))
<|> ((:) <$> pBareAtom [Special ',']
<*> pToList (pDecl acceptType False))
<|> (if acceptType then pTypeEnding else empty)
<|> (if acceptEqu then pEquEnding else empty))
where pTypeEnding = (:) <$> (TS <$> exact [ReservedOp DoubleColon]
<*> pTypeExpr') <*> pure []
pEquEnding = (:) <$> pFunRHS (ReservedOp Equal) <*> pure []
pFunDecl = pDecl True True
pTypeDecl = pDecl True False
pEq :: Token -> Parser TT (Exp TT)
pEq equalSign = RHS <$> pBareAtom [equalSign] <*> pExpr'
pMany :: Parser TT (Exp TT) -> Parser TT (Exp TT)
pMany p = Expr <$> many p
pBlocks :: Parser TT r -> Parser TT [r]
pBlocks p = p `sepBy1` exact [nextLine]
pBlocks' p = pBlocks p <|> pure []
pBlockOf :: Parser TT (Exp TT) -> Parser TT (Exp TT)
pBlockOf p = Block <$> pBlockOf' (pBlocks p)
pBlock :: Parser TT (Exp TT) -> Parser TT (Exp TT)
pBlock p = pBlockOf' (Block <$> pBlocks' p)
<|> pEBrace (p `sepBy1` exact [Special ';'] <|> pure [])
<|> (Yuck $ Enter "block expected" pEmptyBL)
pBlockOf' :: Parser TT a -> Parser TT a
pBlockOf' p = exact [startBlock] *> p <* exact [endBlock]
pTopDecl :: Parser TT (Exp TT)
pTopDecl = pFunDecl
<|> pType
<|> pData
<|> pClass
<|> pure emptyNode
pExpr' = pExpr recognizedSometimes
recognizedSometimes = [ReservedOp DoubleDot,
Special ',',
ReservedOp Pipe,
ReservedOp Equal,
ReservedOp LeftArrow,
ReservedOp RightArrow,
ReservedOp DoubleRightArrow,
ReservedOp BackSlash,
ReservedOp DoubleColon
]
pExpr :: [Token] -> Parser TT (Exp TT)
pExpr at = Expr <$> pExprOrPattern True at
pExprOrPattern :: Bool -> [Token] -> Parser TT [Exp TT]
pExprOrPattern isExpresssion at =
pure []
<|> ((:) <$> pElem isExpresssion at <*> pExprOrPattern True at)
<|> ((:) <$> (TS <$> exact [ReservedOp DoubleColon] <*> pTypeExpr')
<*> pure [])
pPattern = pExprOrPattern False recognizedSometimes
pExprElem = pElem True
pElem :: Bool -> [Token] -> Parser TT (Exp TT)
pElem isExpresssion at =
pCParen (pExprOrPattern isExpresssion
(recognizedSometimes \\ [Special ','])) pEmpty
<|> pCBrack (pExprOrPattern isExpresssion
(recognizedSometimes \\ [ ReservedOp DoubleDot, ReservedOp Pipe
, ReservedOp LeftArrow
, Special ','])) pEmpty
<|> pCBrace (many $ pElem isExpresssion
(recognizedSometimes \\ [ ReservedOp Equal, Special ','
, ReservedOp Pipe])) pEmpty
<|> (Yuck $ Enter "incorrectly placed block" $
pBlockOf (pExpr recognizedSometimes))
<|> (PError <$> recoverWith
(sym $ flip elem $ isNoiseErr at) <*> errTok <*> pEmpty)
<|> (PAtom <$> sym (`notElem` isNotNoise at) <*> pEmpty)
<|> if isExpresssion then pLet <|> pDo <|> pOf <|> pLambda else empty
pTypeExpr at = many (pTypeElem at)
pTypeExpr' = pTypeExpr (recognizedSometimes \\ [ReservedOp RightArrow,
ReservedOp DoubleRightArrow])
pTypeElem :: [Token] -> Parser TT (Exp TT)
pTypeElem at
= pCParen (pTypeExpr (recognizedSometimes
\\ [ ReservedOp RightArrow,
ReservedOp DoubleRightArrow,
Special ','])) pEmpty
<|> pCBrack pTypeExpr' pEmpty
<|> pCBrace pTypeExpr' pEmpty
<|> (Yuck $ Enter "incorrectly placed block" $
pBlockOf (pExpr recognizedSometimes))
<|> (PError <$> recoverWith
(sym $ flip elem $ isNoiseErr at) <*> errTok <*> pEmpty)
<|> (PAtom <$> sym (`notElem` isNotNoise at) <*> pEmpty)
isNoiseErr :: [Token] -> [Token]
isNoiseErr r = recoverableSymbols ++ r
recoverableSymbols = recognizedSymbols \\ fmap Special "([{<>."
isNotNoise :: [Token] -> [Token]
isNotNoise r = recognizedSymbols ++ r
recognizedSymbols =
[ Reserved Let
, Reserved In
, Reserved Do
, Reserved Of
, Reserved Class
, Reserved Instance
, Reserved Deriving
, Reserved Module
, Reserved Import
, Reserved Type
, Reserved Data
, Reserved NewType
, Reserved Where] ++ fmap Special "()[]{}<>."
pCParen, pCBrace, pCBrack
:: Parser TT [Exp TT] -> Parser TT [TT] -> Parser TT (Exp TT)
pCParen p c = Paren <$> pCAtom [Special '('] c
<*> p <*> (recoverAtom <|> pCAtom [Special ')'] c)
pCBrace p c = Paren <$> pCAtom [Special '{'] c
<*> p <*> (recoverAtom <|> pCAtom [Special '}'] c)
pCBrack p c = Paren <$> pCAtom [Special '['] c
<*> p <*> (recoverAtom <|> pCAtom [Special ']'] c)
pParen, pBrack :: Parser TT [Exp TT] -> Parser TT (Exp TT)
pParen = flip pCParen pComments
pBrack = flip pCBrack pComments
pEBrace p = Paren <$> pCAtom [Special '{'] pEmpty
<*> p <*> (recoverAtom <|> pCAtom [Special '}'] pComments)
errTok = mkTok <$> curPos
where curPos = tB <$> lookNext
tB Nothing = maxBound
tB (Just x) = tokBegin x
mkTok p = Tok (Special '!') 0 (startPosn {posnOfs = p})