CirruParser (empty) → 0.0.1
raw patch · 5 files changed
+420/−0 lines, 5 filesdep +aesondep +basedep +textsetup-changed
Dependencies added: aeson, base, text, vector
Files
- CirruParser.cabal +29/−0
- README.md +17/−0
- Setup.hs +5/−0
- src/Cirru.hs +144/−0
- src/CirruParser.hs +225/−0
+ CirruParser.cabal view
@@ -0,0 +1,29 @@++name: CirruParser+version: 0.0.1+cabal-version: >= 1.22+license: MIT+license-file: README.md+description: Cirru Parser in Haskell+author: JiyinYiyong+maintainer: jiyiyiyiony@gmail.com+homepage: https://github.com/Cirru/parser.hs+category: Text+synopsis: Cirru Parser in Haskell++build-type: Simple+cabal-version: >= 1.10++source-repository head+ type: git+ location: git://github.com/Cirru/parser.hs.git++library+ hs-source-dirs: src/+ build-depends:+ base >= 4 && < 5,+ text,+ vector,+ aeson+ default-language: Haskell2010+ exposed-modules: CirruParser, Cirru
+ README.md view
@@ -0,0 +1,17 @@++Cirru Parser in Haskell+----++Reimplement Cirru Parser in Haskell.++Code is now OK, but I have to make it a package...++Test:++```bash+runghc main.hs+```++### License++MIT
+ Setup.hs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runghc++import Distribution.Simple++main = defaultMain
+ src/Cirru.hs view
@@ -0,0 +1,144 @@++module Cirru+( CirruValue(..)+, CirruState(..)+, CrValue(..)+, CirruBuffer(..)+, createNesting+, appendItem+, resolveDollar+, resolveComma+) where++import Data.Text (pack, unpack)+import Data.Aeson.Types (Array)+import Data.List+import qualified Data.Vector as V+import Debug.Trace+import Data.Aeson+import Data.Traversable (traverse)+import Data.Foldable (toList)+import Control.Applicative++-- Buffer++data CirruBuffer = CirruBuffer { bText :: String+ , bX :: Integer+ , bY :: Integer+ }++instance Show CirruBuffer where+ show (CirruBuffer text _ _) = text++-- Short Value++data CrValue = CrList [CrValue] | CrString String++instance Show CrValue where+ show (CrString a) = a+ show (CrList a) = "[" ++ (intercalate "," (map show a)) ++"]"++instance FromJSON CrValue where+ parseJSON v =+ withText "CrString" (pure . CrString . unpack) v+ <|> withArray "CrList" (\a -> CrList . toList <$> traverse parseJSON a) v++instance ToJSON CrValue where+ toJSON (CrString text) = String $ pack text+ toJSON (CrList list) = Array $ V.fromList (map toJSON list)++-- Value++data CirruValue = CirruList [CirruValue] | CirruToken { tText :: String+ , tX :: Integer+ , tY :: Integer+ , tEx :: Integer+ , tEy :: Integer+ , tPath :: String+ }++instance Show CirruValue where+ show (CirruToken text _ _ _ _ _) = text+ show (CirruList a) = "{" ++ (intercalate "," (map show a)) ++ "}"++instance ToJSON CirruValue where+ toJSON (CirruToken text _ _ _ _ _) = String (pack text)+ toJSON (CirruList list) = Array $ V.fromList (map toJSON list)++-- State++data CirruState = CirruState { sName :: String+ , sX :: Integer+ , sY :: Integer+ , sLevel :: Integer+ , sIndent :: Integer+ , sIndented :: Integer+ , sNest :: Integer+ , sPath :: String+ }++instance Show CirruState where+ show (CirruState name x y level indent indented nest path) =+ name ++ " l:" ++ (show level) ++ " i:" ++ (show indent) ++ "," ++ (show indented) ++ " " ++ (show nest)++-- Manipulations++appendItem :: CirruValue -> Integer -> CirruValue -> CirruValue+appendItem (CirruToken _ _ _ _ _ _) _ _ = error "can not append to token"+appendItem (CirruList xs) 0 x = CirruList (xs ++ [x])+appendItem (CirruList xs) n x =+ CirruList (before ++ after2)+ where+ before = init xs+ lastItem = last xs+ (CirruList after) = appendItem lastItem (n - 1) x+ after2 = [CirruList after]++createNesting :: Integer -> CirruValue+createNesting 1 = CirruList []+createNesting n = CirruList [(createNesting (n - 1))]++repeatDollar :: CirruValue -> CirruValue -> CirruValue+repeatDollar (CirruList xs) (CirruList []) = (CirruList xs)+repeatDollar (CirruList before) (CirruList after) =+ if (length after) == 0+ then CirruList before+ else case (head after) of+ (CirruList cursor) ->+ repeatDollar (CirruList (before ++ [CirruList newCursor])) (CirruList (tail after))+ where (CirruList newCursor) = resolveDollar (CirruList cursor)+ (CirruToken "$" _ _ _ _ _) ->+ CirruList (before ++ [CirruList newAfter])+ where (CirruList newAfter) = resolveDollar (CirruList (tail after))+ (CirruToken s _ _ _ _ _) ->+ repeatDollar (CirruList (before ++ [head after])) (CirruList (tail after))++resolveDollar :: CirruValue -> CirruValue+resolveDollar (CirruList []) = (CirruList [])+resolveDollar (CirruList xs) = repeatDollar (CirruList []) (CirruList xs)++repeatComma :: CirruValue -> CirruValue -> CirruValue+repeatComma (CirruList xs) (CirruList []) = (CirruList xs)+repeatComma (CirruList before) (CirruList after) =+ if (length after) == 0+ then CirruList before+ else case (head after) of+ (CirruToken _ _ _ _ _ _) ->+ repeatComma (CirruList (before ++ [head after])) (CirruList (tail after))+ (CirruList cursor) ->+ if (length cursor) == 0+ then repeatComma (CirruList (before ++ [head after])) (CirruList (tail after))+ else case (head cursor) of+ (CirruList _) ->+ repeatComma (CirruList (before ++ [CirruList newCursor])) (CirruList (tail after))+ where (CirruList newCursor) = resolveComma (CirruList cursor)+ (CirruToken "," _ _ _ _ _) ->+ repeatComma (CirruList before) (CirruList (newCursor ++ (tail after)))+ where (CirruList newCursor) = resolveComma (CirruList (tail cursor))+ (CirruToken _ _ _ _ _ _) ->+ repeatComma (CirruList (before ++ [CirruList newCursor])) (CirruList (tail after))+ where (CirruList newCursor) = resolveComma (CirruList cursor)++resolveComma :: CirruValue -> CirruValue+resolveComma (CirruList []) = (CirruList [])+resolveComma (CirruList xs) = repeatComma (CirruList []) (CirruList xs)
+ src/CirruParser.hs view
@@ -0,0 +1,225 @@++module CirruParser+( parse+, pare+) where++import Cirru+import Debug.Trace++isEmpty :: String -> Bool+isEmpty [] = True+isEmpty _ = False++emptyList = CirruList []++parse :: String -> String -> CirruValue+parse code filename =+ parseState emptyList buffer startState code+ where+ buffer = CirruBuffer "" 1 1+ startState = CirruState "indent" 1 1 1 0 0 0 filename+++cr :: CirruValue -> CrValue+cr (CirruToken x _ _ _ _ _) = CrString x+cr (CirruList xs) = CrList (map cr xs)++pare :: String -> String -> CrValue+pare code filename = cr (parse code filename)++newState x = x++log2 :: CirruValue -> CirruBuffer -> CirruState -> String -> String+log2 xs buffer state code = "\nstate:\t" ++ (show state) ++ "\ncode:\t" ++ (show code)+ ++ "\nxs:\t" ++ (show xs) ++ "\nbuffer:\t" ++ (show buffer)++parseState2 :: CirruValue -> CirruBuffer -> CirruState -> String -> CirruValue+parseState2 xs buffer state code = trace (log2 xs buffer state code) $ parseState xs buffer state code++parseState :: CirruValue -> CirruBuffer -> CirruState -> String -> CirruValue+parseState xs buffer state code =+ if (isEmpty code)+ then case (sName state) of+ ("escape") -> escapeEof xs buffer state code+ ("string") -> stringEof xs buffer state code+ ("space") -> spaceEof xs buffer state code+ ("token") -> tokenEof xs buffer state code+ ("indent") -> indentEof xs buffer state code+ else case (sName state) of+ ("escape") ->+ case (head code) of+ ('\n') -> escapeNewline xs buffer state code+ ('n') -> escapeN xs buffer state code+ ('t') -> escapeT xs buffer state code+ _ -> escapeElse xs buffer state code+ ("string") ->+ case (head code) of+ ('\\') -> stringBackslash xs buffer state code+ ('\n') -> stringNewline xs buffer state code+ ('\"') -> stringQuote xs buffer state code+ _ -> stringElse xs buffer state code+ ("space") ->+ case (head code) of+ (' ') -> spaceSpace xs buffer state code+ ('\n') -> spaceNewline xs buffer state code+ ('(') -> spaceOpen xs buffer state code+ (')') -> spaceClose xs buffer state code+ ('"') -> spaceQuote xs buffer state code+ _ -> spaceElse xs buffer state code+ ("token") ->+ case (head code) of+ (' ') -> tokenSpace xs buffer state code+ ('\n') -> tokenNewline xs buffer state code+ ('(') -> tokenOpen xs buffer state code+ (')') -> tokenClose xs buffer state code+ ('"') -> tokenQuote xs buffer state code+ _ -> tokenElse xs buffer state code+ ("indent") ->+ case (head code) of+ (' ') -> indentSpace xs buffer state code+ ('\n') -> indentNewline xs buffer state code+ (')') -> indentClose xs buffer state code+ _ -> indentElse xs buffer state code+ _ -> error ("unknown state: " ++ (sName state))++escapeEof xs buffer state code = error "EOF in escape state"++stringEof xs buffer state code = error "EOF in string state"++spaceEof xs buffer state code = xs++tokenEof xs b s code =+ let newToken = CirruToken (bText b) (bX b) (bY b) (sX s) (sY s) (sPath s)+ newXs = appendItem xs (sLevel s) newToken+ in newXs++indentEof xs buffer state code = xs+++escapeNewline xs buffer state code = error "new line while escape"++escapeN :: CirruValue -> CirruBuffer -> CirruState -> String -> CirruValue+escapeN xs b s code =+ let newState = CirruState "string" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s)+ newBuffer = CirruBuffer ((bText b) ++ "\n") (bX b) (bY b)+ in parseState xs newBuffer newState (tail code)++escapeT xs b s code =+ let newState = CirruState "string" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s)+ newBuffer = CirruBuffer ((bText b) ++ "\t") (bX b) (bY b)+ in parseState xs newBuffer newState (tail code)++escapeElse xs b s code =+ let newState = CirruState "string" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s)+ newBuffer = CirruBuffer ((bText b) ++ [head code]) (bX b) (bY b)+ in parseState xs newBuffer newState (tail code)++stringBackslash xs b s code =+ let newState = CirruState "escape" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s)+ in parseState xs b newState (tail code)++stringNewline xs buffer state code = error "newline in a string"++stringQuote xs b s code =+ let newState = CirruState "token" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s)+ in parseState xs b newState (tail code)++stringElse xs b s code =+ let newState = CirruState (sName s) ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s)+ newBuffer = CirruBuffer ((bText b) ++ [head code]) (bX b) (bY b)+ in parseState xs newBuffer newState (tail code)++spaceSpace xs b s code =+ let newState = CirruState (sName s) ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s)+ in parseState xs b newState (tail code)++spaceNewline xs b s code =+ if (mod (sNest s) 2) == 1+ then error "incorrect nesting"+ else+ let newState = CirruState "indent" 1 ((sY s)+1) (sLevel s) (sIndent s) 0 (sNest s) (sPath s)+ in parseState xs b newState (tail code)++spaceOpen xs b s code =+ let nesting = createNesting 1+ newXs = appendItem xs (sLevel s) nesting+ newState = CirruState (sName s) ((sX s)+1) (sY s) ((sLevel s)+1) (sIndent s) (sIndented s) ((sNest s)+1) (sPath s)+ in parseState newXs b newState (tail code)++spaceClose xs b s code =+ if ((sNest s) < 1)+ then error "close at space"+ else+ let newState = CirruState (sName s) ((sX s)+1) (sY s) ((sLevel s)-1) (sIndent s) (sIndented s) ((sNest s)-1) (sPath s)+ in parseState xs b newState (tail code)++spaceQuote xs b s code =+ let newState = CirruState "string" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s)+ newBuffer = CirruBuffer "" (sX s) (sY s)+ in parseState xs newBuffer newState (tail code)++spaceElse xs b s code =+ let newState = CirruState "token" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s)+ newBuffer = CirruBuffer [head code] (sX s) (sY s)+ in parseState xs newBuffer newState (tail code)++tokenSpace xs b s code =+ let newState = CirruState "space" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s)+ newToken = CirruToken (bText b) (bX b) (bY b) (sX s) (sY s) (sPath s)+ newXs = appendItem xs (sLevel s) newToken+ in parseState newXs b newState (tail code)++tokenNewline xs b s code =+ let newState = CirruState "indent" 1 ((sY s)+1) (sLevel s) (sIndent s) 0 (sNest s) (sPath s)+ newToken = CirruToken (bText b) (bX b) (bY b) (sX s) (sY s) (sPath s)+ newXs = appendItem xs (sLevel s) newToken+ in parseState newXs b newState (tail code)++tokenOpen xs buffer state code = error "open parenthesis in token"++tokenClose xs b s code =+ let newState = CirruState "space" (sX s) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s)+ newToken = CirruToken (bText b) (bX b) (bY b) (sX s) (sY s) (sPath s)+ newXs = appendItem xs (sLevel s) newToken+ in parseState newXs b newState code++tokenQuote xs b s code =+ let newState = CirruState "string" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s)+ in parseState xs b newState (tail code)++tokenElse xs b s code =+ let newState = CirruState (sName s) ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s)+ newBuffer = CirruBuffer ((bText b) ++ [head code]) ((sX s)+1) (sY s)+ in parseState xs newBuffer newState (tail code)++indentSpace xs b s code =+ let newState = CirruState (sName s) ((sX s)+1) (sY s) (sLevel s) (sIndent s) ((sIndented s)+1) (sNest s) (sPath s)+ in parseState xs b newState (tail code)++indentNewline xs b s code =+ let newState = CirruState (sName s) 1 ((sY s)+1) (sLevel s) (sIndent s) 0 (sNest s) (sPath s)+ in parseState xs b newState (tail code)++indentClose xs buffer state code = error "close parenthesis at indent"++indentElse xs b s code =+ if (mod (sIndented s) 2) == 1+ then error ("odd indentation: " ++ (show (sIndented s)))+ else+ let indented = div (sIndented s) 2+ diff = indented - (sIndent s)+ nesting = createNesting 1+ newState = CirruState "space" (sX s) (sY s) ((sLevel s)+diff) indented (sIndented s) (sNest s) (sPath s)+ in+ if diff <= 0+ then+ let newXs = appendItem xs ((sLevel s) + diff - 1) nesting+ in parseState newXs b newState code+ else+ if diff > 0+ then+ let newXs = appendItem xs (sLevel s) nesting+ in parseState newXs b newState code+ else+ parseState xs b newState code