nanoParse.hs

{-# Language InstanceSigs #-}
{-# Language MultiWayIf #-}
{-# Language RankNTypes #-}

import Control.Applicative
import Data.Char
import Data.Bifunctor (first)

type Parser' a = String -> a

type Parser'' a = String -> (a, String)

type Parser''' a = String -> Maybe (a, String)

parseNum :: Parser''' Int
parseNum = runParser (token int)

parsePlus :: Parser''' Char
parsePlus = runParser (token (char '+'))

eval :: String -> Maybe Int
eval s =
  case parseNum s of
    Nothing      -> Nothing
    Just (n, s') -> 
      case parsePlus s' of
        Nothing         -> Nothing
        Just ('+', s'') ->
          case parseNum s'' of
            Nothing      -> Nothing
            Just (m, "") -> pure $ n + m

-- eval "2 + 3"

-- What does making Parser an instance of monad buy us?
parseSum :: Parser Int
parseSum = do
  n <- token int
  token (char '+')
  m <- token int
  pure $ n + m
  
-- runParser parseSum "2 + 3"

parseSum' :: Parser Int
parseSum' =
  token int        >>= \n ->
  token (char '+') >> 
  token int        >>= \m ->
  pure $ n + m

-- What are we going to parse?
-- runParser vehicle "bike Yamaha"
-- runParser vehicle "car Ford"
-- runParser vehicle "truck 4 MAC"
data Vehicle = Vehicle
  { vType :: VType
  , vAxels :: Int
  , vModel :: String -- e.g. Subaru, Chevy, etc.
  } deriving Show

data VType = Bike | Car | Truck
  deriving Show

newtype Parser a = Parser {runParser :: String -> Maybe (a, String)}

-- fmap f ma = pure f <*> ma
-- fmap f ma = ma >>= (pure . f)
-- fmap = liftM
instance Functor Parser where
  fmap :: (a -> b) -> Parser a -> Parser b
  -- first :: (a -> b) -> (a, c) -> (b, c)
  -- <$> infix form of fmap
  fmap f m = Parser $ \s -> first f <$> runParser m s
{-  
fmap f m = Parser $ \s ->
    case runParser m s of
      Nothing -> empty
      Just (a, s) -> pure (f a, s)
-}

-- mab <*> ma = do
--   f <- mab
--   a <- ma
--   pure $ f a
-- (<*>) = ap
instance Applicative Parser where
  pure :: a -> Parser a
  pure a = Parser $ \s -> Just (a, s)

  (<*>) :: Parser (a -> b) -> Parser a -> Parser b
  k <*> m = Parser $
    \s -> do           -- use the Maybe monad
      (f, s')  <- runParser k s
      (a, s'') <- runParser m s'
      pure (f a, s'')

instance Monad Parser where
  (>>=) :: Parser a -> (a -> Parser b) -> Parser b
  m >>= k = Parser $
    \s -> do
      (a', s') <- runParser m s
      runParser (k a') s'

-- Gives us 'some' (one or more) and 'many' (zero or more)
-- for free
-- some :: Parser a -> Parser [a]
-- many :: Parser a -> Parser [a]
instance Alternative Parser where
  empty :: Parser a
  empty = Parser $ \s -> Nothing

  (<|>) :: Parser a -> Parser a -> Parser a
  m <|> n = Parser $
    \s -> case runParser m s of
      Just (a, s') -> Just (a, s')
      Nothing -> runParser n s

satisfy :: (Char -> Bool) -> Parser Char
satisfy f = Parser $ 
          \s -> case s of
            []     -> Nothing   
            (x:xs) -> if f x then Just (x, xs) else Nothing

oneOf :: [Char] -> Parser Char
oneOf s = satisfy (\c -> c `elem` s)
        
char :: Char -> Parser Char
char c = satisfy (c ==)

-- Case insensitive
string :: String -> Parser String
string [] = pure []
string s@(x:xs) = do
  char x <|> char (toUpper x)
  string xs 
  pure s

spaces :: Parser String
spaces = many $ oneOf " \n\r"

token :: Parser a -> Parser a
token p = do
  a <- p
  spaces
  pure a

digit :: Parser Char
digit = satisfy isDigit

int :: Parser Int
int = do
  s  <- string "-" <|> pure ""
  cs <- some digit
  pure $ read (s <> cs)

parens :: Parser a -> Parser a
parens p = do
  token (string "(")
  a <- p
  token (string ")")
  pure a

posInt :: Parser Int
posInt = do
  ds <- some digit
  pure $ read ds

bike :: Parser VType
bike = do
 token (string "bike" <|> string "motorcycle")
 pure Bike

car :: Parser VType
car = do
  token (string "car" <|> string "automobile")
  pure Car
  
truck :: Parser VType
truck = do
  token $ string "truck"
  pure Truck

vtype :: Parser VType
vtype = bike <|> car <|> truck

axles :: VType -> Parser Int
axles Bike = pure 0
axles Car = pure 2
axles Truck = posInt

model :: Parser String
model = many $ satisfy (\_ -> True)

vehicle :: Parser Vehicle
vehicle = do
  vt <- vtype
  ax <- axles vt
  md <- model
  pure $ Vehicle vt ax md

-- CPS Style ------------------------------------------------------
-------------------------------------------------------------------
newtype ParserCPS a = ParserCPS
  { parseCPS
      :: forall r. String
      -> (a -> String -> r)
      -> r
      -> r
  }

runParserCPS :: ParserCPS a -> String -> Maybe (a, String)
runParserCPS m s = parseCPS m s (\a s' -> Just (a, s')) Nothing

instance Functor ParserCPS where
  fmap :: (a -> b) -> ParserCPS a -> ParserCPS b
  fmap f m = ParserCPS $ \s k e -> parseCPS m s (k . f) e 

instance Applicative ParserCPS where
  pure :: a -> ParserCPS a
  pure a = ParserCPS $ \s k' _ -> k' a s

  (<*>) :: ParserCPS (a -> b) -> ParserCPS a -> ParserCPS b
  k <*> m = ParserCPS $ \s k' e ->
    let qk f s' = parseCPS m s' (k' . f) e
    in  parseCPS k s qk e

instance Monad ParserCPS where
  (>>=) :: ParserCPS a -> (a -> ParserCPS b) -> ParserCPS b
  m >>= k = ParserCPS $ \s k' e ->
    let q x s' = parseCPS (k x) s' k' e
    in  parseCPS m s q e

instance Alternative ParserCPS where
  empty :: ParserCPS a
  empty = ParserCPS $ \_ _ e -> e

  (<|>) :: ParserCPS a -> ParserCPS a -> ParserCPS a
  m <|> n = ParserCPS $ \s k e ->
    let ife = parseCPS n s k e 
    in parseCPS m s k ife
    
satisfyCPS :: (Char -> Bool) -> ParserCPS Char
satisfyCPS f = ParserCPS $ \s k e ->
  case s of
    [] -> e
    (x:xs) -> if f x then k x xs else e

oneOfCPS :: [Char] -> ParserCPS Char
oneOfCPS s = satisfyCPS (\c -> c `elem` s)

charCPS :: Char -> ParserCPS Char
charCPS c = satisfyCPS (c ==)

stringCPS :: String -> ParserCPS String
stringCPS [] = pure []
stringCPS s@(x:xs) = do
  charCPS x <|> charCPS (toUpper x)
  stringCPS xs 
  pure s

spacesCPS :: ParserCPS String
spacesCPS = many $ oneOfCPS " \n\r"

tokenCPS :: ParserCPS a -> ParserCPS a
tokenCPS p = do
  a <- p
  spacesCPS
  pure a
  
digitCPS :: ParserCPS Char
digitCPS = satisfyCPS isDigit

intCPS :: ParserCPS Int
intCPS = do
  s  <- stringCPS "-" <|> pure ""
  cs <- some digitCPS
  pure $ read (s <> cs)
  
parensCPS :: ParserCPS a -> ParserCPS a
parensCPS p = do
  tokenCPS (stringCPS "(")
  a <- p
  tokenCPS (stringCPS ")")
  pure a

posIntCPS :: ParserCPS Int
posIntCPS = do
  ds <- some digitCPS
  pure $ read ds

bikeCPS :: ParserCPS VType
bikeCPS = do
 tokenCPS (stringCPS "bike" <|> stringCPS "motorcycle")
 pure Bike

carCPS :: ParserCPS VType
carCPS = do
  tokenCPS (stringCPS "car" <|> stringCPS "automobile")
  pure Car

truckCPS :: ParserCPS VType
truckCPS = do
  tokenCPS $ stringCPS "truck"
  pure Truck

vtypeCPS :: ParserCPS VType
vtypeCPS = bikeCPS <|> carCPS <|> truckCPS

axlesCPS :: VType -> ParserCPS Int
axlesCPS Bike = pure 0
axlesCPS Car = pure 2
axlesCPS Truck = posIntCPS

modelCPS :: ParserCPS String
modelCPS = many $ satisfyCPS (\_ -> True)

vehicleCPS :: ParserCPS Vehicle
vehicleCPS = do
  vt <- vtypeCPS
  ax <- axlesCPS vt
  md <- modelCPS
  pure $ Vehicle vt ax md

main :: IO () 
main = putStrLn("Hello nano parse")