module Yi.Syntax.Haskell ( PModule
, PModuleDecl
, PImport
, Exp (..)
, Tree
, parse
, indentScanner
) where
import Control.Applicative (Alternative ((<|>), empty, many, some),
Applicative (..), optional, (<$>))
import Control.Arrow ((&&&))
import Data.Foldable (Foldable)
import Data.List ((\\))
import Data.Maybe (fromJust, isNothing)
import Yi.IncrementalParse
import Yi.Lexer.Alex (Posn (Posn, posnOfs), Tok (Tok, tokT),
startPosn, tokBegin)
import Yi.Lexer.Haskell
import Yi.Syntax (Scanner)
import Yi.Syntax.Layout (State, layoutHandler)
import Yi.Syntax.Tree (IsTree (emptyNode, uniplate), sepBy1)
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})