Main.hs (5778B)
1 module Main where 2 3 import Control.Applicative 4 import Control.Monad 5 import Data.ByteString (ByteString) 6 import Data.Char 7 8 import Sparsec qualified as P 9 10 -------------------------------------------------------------------------------- 11 -- Surface syntax 12 13 newtype XtorName = XtorName ByteString deriving (Show, Eq, Ord) 14 newtype TypeName = TypeName ByteString deriving (Show, Eq, Ord) 15 newtype TermName = TermName ByteString deriving (Show, Eq, Ord) 16 newtype StmtName = StmtName ByteString deriving (Show, Eq, Ord) 17 18 data PosNeg = Pos | Neg deriving (Show) 19 data PrdCns = Prd | Cns deriving (Show) 20 21 data DeclParam = DeclParam TypeName Kind deriving (Show) 22 data DeclField = DeclField PrdCns Type deriving (Show) 23 data DeclXtor = DeclXtor XtorName [DeclParam] [DeclField] deriving (Show) 24 data Decl = Decl PosNeg TypeName [DeclParam] [DeclXtor] deriving (Show) 25 26 data Kind 27 = KindType PosNeg 28 | KindArrow Kind Kind 29 deriving (Show) 30 31 data Type 32 = TypeVar TypeName 33 | TypeLam TypeName (Maybe Kind) Type 34 | TypeApp Type Type 35 deriving (Show) 36 37 data Case = Case XtorName [TermName] Stmt deriving (Show) 38 data Term 39 = TermVar TermName 40 | TermMu TermName (Maybe Type) Stmt 41 | TermXtor XtorName [Type] [Term] 42 | TermMatch [Case] 43 deriving (Show) 44 45 data Stmt 46 = StmtCut Term Type Term -- TODO: Should Cut be a special case of Cmd? 47 | StmtCmd StmtName [Type] [Term] 48 deriving (Show) 49 50 data Prog = Prog [Decl] Stmt deriving (Show) 51 52 -------------------------------------------------------------------------------- 53 -- Parser 54 55 data Err = Err deriving (Show) -- TODO 56 57 type P a = P.Parse Err a 58 59 isLetterOrDigit c = isLetter c || isDigit c 60 isWordStart c = isLetter c || c == '_' 61 isWordCont c = isLetterOrDigit c || c == '_' || c == '\'' 62 63 isKw s = s == "data" || s == "prd" || s == "cns" 64 65 pWs = P.many_ (P.charIf isSpace) 66 pToken p = p <* pWs 67 pSym = pToken . P.string 68 pWord = snd <$> (P.bytesOf $ P.charIf isWordStart *> P.charWhile isWordCont) 69 pKw s = do 70 s' <- pToken pWord 71 guard (s' == s) 72 pIdent = do 73 x <- pToken pWord 74 guard $ not $ isKw x 75 pure x 76 pDelim l p r = pSym l *> (p <* pSym r) `P.cut` Err 77 pManySepByWithTrailer p sep = p `P.someSepBy` sep <* optional sep <|> pure [] 78 pList p = p `pManySepByWithTrailer` pSym "," 79 80 pXtorName = XtorName <$> pToken (P.char '#' *> pWord `P.cut` Err) 81 pTypeName = TypeName <$> pIdent 82 pTermName = TermName <$> pIdent 83 pStmtName = StmtName <$> pToken (P.char '@' *> pWord `P.cut` Err) 84 85 pPosNeg = pSym "+" *> pure Pos <|> pSym "-" *> pure Neg 86 pPrdCns = pKw "prd" *> pure Prd <|> pKw "cns" *> pure Cns 87 88 pDeclParam :: Int -> P DeclParam 89 pDeclParam = \case 90 0 -> DeclParam <$> pTypeName <*> P.branch (pSym ":") (pKind 0 `P.cut` Err) (pure $ KindType Pos) 91 1 -> DeclParam <$> pTypeName <*> pure (KindType Pos) <|> pDelim "(" (pDeclParam 0) ")" 92 _ -> error "pDeclParam: invalid precedence" 93 94 pDeclField :: Int -> P DeclField 95 pDeclField = \case 96 0 -> DeclField <$> (pPrdCns <|> pure Prd) <*> pType 0 97 1 -> DeclField Prd <$> pTypeAtom <|> pDelim "(" (pDeclField 0) ")" 98 _ -> error "pDeclField: invalid precedence" 99 100 pDeclXtor = do 101 x <- pXtorName 102 params <- pDelim "[" (many (pDeclParam 1)) "]" <|> pure [] 103 fields <- many (pDeclField 1) 104 pure $ DeclXtor x params fields 105 106 pDecl = do 107 pKw "data" 108 x <- pTypeName 109 params <- many (pDeclParam 1) 110 posneg <- P.branch (pSym ":") (pPosNeg `P.cut` Err) (pure Pos) 111 xtors <- pDelim "{" (pList pDeclXtor) "}" 112 pure $ Decl posneg x params xtors 113 114 pKindArrow dom = pSym "->" *> (KindArrow dom <$> pKind 0) `P.cut` Err 115 116 pKind :: Int -> P Kind 117 pKind = \case 118 0 -> do 119 k <- pKind 1 120 pKindArrow k <|> pure k 121 1 -> KindType <$> pPosNeg <|> pDelim "(" (pKind 0) ")" 122 _ -> error "pKind: invalid precedence" 123 124 pTypeLam = do 125 pSym "\\" 126 x <- pTypeName `P.cut` Err 127 mk <- optional (pSym ":" *> pKind 0 `P.cut` Err) 128 pSym "=>" `P.cut` Err 129 body <- pType 0 `P.cut` Err 130 pure $ TypeLam x mk body 131 132 pTypeAtom = TypeVar <$> pTypeName 133 134 pType :: Int -> P Type 135 pType = \case 136 0 -> pTypeLam <|> pType 1 137 1 -> pType 2 >>= P.iter \a -> TypeApp a <$> pType 2 138 2 -> pTypeAtom <|> pDelim "(" (pType 0) ")" 139 _ -> error "pType: invalid precedence" 140 141 pCase = do 142 x <- pXtorName 143 vars <- many pTermName 144 pSym "=>" `P.cut` Err 145 body <- pStmt `P.cut` Err 146 pure $ Case x vars body 147 148 pTermMu = do 149 pSym "\\" 150 x <- pTermName `P.cut` Err 151 ma <- optional (pSym ":" *> pType 1 `P.cut` Err) 152 pSym "=>" `P.cut` Err 153 body <- pStmt `P.cut` Err 154 pure $ TermMu x ma body 155 156 pTermArg = pTerm 2 <|> TermXtor <$> pXtorName <*> pure [] <*> pure [] 157 158 args = do 159 tyArgs <- pDelim "[" (many (pType 2)) "]" <|> pure [] 160 tmArgs <- many pTermArg 161 pure (tyArgs, tmArgs) 162 163 pTermXtor = do 164 x <- pXtorName 165 (tyArgs, tmArgs) <- args 166 pure $ TermXtor x tyArgs tmArgs 167 168 pTerm :: Int -> P Term 169 pTerm = \case 170 0 -> pTermMu <|> pTerm 1 171 1 -> pTermXtor <|> pTerm 2 172 2 -> 173 TermVar <$> pTermName 174 <|> TermMatch <$> pDelim "{" (pList pCase) "}" 175 <|> pDelim "(" (pTerm 0) ")" 176 _ -> error "pTerm: invalid precedence" 177 178 pStmtCmd = do 179 x <- pStmtName 180 (tyArgs, tmArgs) <- args 181 pure $ StmtCmd x tyArgs tmArgs 182 183 pStmtCut = do 184 prd <- pTerm 0 185 pSym ":" `P.cut` Err 186 typ <- pType 0 `P.cut` Err 187 pSym ":" `P.cut` Err 188 cns <- pTerm 0 `P.cut` Err 189 pure $ StmtCut prd typ cns 190 191 pStmt = pStmtCmd <|> pStmtCut 192 193 pProg :: P Prog 194 pProg = Prog <$> many pDecl <*> pStmt 195 196 pSrc :: P Prog 197 pSrc = pWs *> pProg <* P.eof 198 199 -------------------------------------------------------------------------------- 200 201 ex :: ByteString 202 ex = "data Bool : + { #true, #false } data Any { #any [A] A, } #true :Bool: \\x=>@print" 203 204 main :: IO () 205 main = print $ P.runParse pSrc ex P.locZero