OldLexer.x

{
{-# OPTIONS_GHC -w #-}
module HyLo.InputFile.OldLexer (lexify, Token(..),
                                FilePos, line, col)

where

import Data.Char ( isSpace )

import HyLo.Signature.Simple ( PropSymbol(..),
                               NomSymbol(..),
                               RelSymbol(..), inv )
}

%wrapper "posn"

$digit = [0-9]                  -- digits
$alpha = [a-zA-Z]               -- alphabetic characters
$alphaNum = [$alpha$digit]

@int = \-?$digit+
@rel = [Rr]@int

hyloTokens :-
  $white+                   ;       -- strip whitspaces
  \%.*                      ;       -- strip comments
  \{ (~\} | \n)* \}         ;       -- strip multiple line comments

  begin                     { discardValue TokenBegin }
  end                       { discardValue TokenEnd   }

  true                      { discardValue TokenTrue  }
  false                     { discardValue TokenFalse }
  [Pp]@int                  { storeValue (TokenProp . prop  . tail) }
  [Nn]@int                  { storeValue (TokenNom  . nom   . tail) }
  [Xx]@int                  { storeValue (TokenVar  . var   . tail) }

  \<$white*@rel?$white*\>   { storeValue (TokenDia . rel . dropEnds) }
  dia                       { discardValue (TokenDia defaultRel)     }

  \<$white*\-@rel?$white*\> { storeValue (TokenDia . relI . tail . dropEnds) }

  \[$white*@rel?$white*\]   { storeValue (TokenBox . rel . dropEnds) }
  box                       { discardValue (TokenBox defaultRel)     }

  \[$white*\-@rel?$white*\] { storeValue (TokenBox . relI . tail . dropEnds) }

  \:                        { discardValue TokenAt  }
  \@                        { discardValue TokenAt2 }

  A                         { discardValue TokenUBox }
  E                         { discardValue TokenUDia }

  D                         { discardValue TokenDDia }
  B                         { discardValue TokenDBox }

  down                      { discardValue TokenDown }

  [v\|]                     { discardValue TokenOr   }
  [&\^]                     { discardValue TokenAnd  }
  [\!\-\~]                  { discardValue TokenNeg  }
  "<-->"                    { discardValue TokenDimp }
  "-->"                     { discardValue TokenImp  }
  "->"                      { discardValue TokenImp  }

  "("                       { discardValue TokenOB }
  ")"                       { discardValue TokenCB }

  \.                        { discardValue TokenDot }
  \;                        { discardValue TokenSC }

{
data Token = TokenBegin           | TokenEnd
           | TokenTrue            | TokenFalse
           | TokenProp PropSymbol | TokenNom NomSymbol  | TokenVar NomSymbol
           | TokenNeg             | TokenAnd            | TokenOr
           | TokenAt              | TokenAt2            | TokenDown
           | TokenBox  RelSymbol  | TokenDia  RelSymbol
           | TokenImp             | TokenDimp
           | TokenUBox            | TokenUDia
           | TokenDBox            | TokenDDia
           | TokenOB              | TokenCB
           | TokenDot             | TokenSC
  deriving (Eq, Show, Read)

data FilePos = FP{line :: Int, col :: Int} deriving (Eq, Show)

makeFilePos (AlexPn _ l c) = FP{line = l, col = c}

lexify :: String -> [(Token, FilePos)]
lexify str = go (alexStartPos,'\n',str)
    where go inp@(pos,_,str) = case alexScan inp 0 of
                                    AlexEOF                       -> []
                                    AlexError (AlexPn _ l c, _,_) -> error $ concat ["Unknown token at line: ", show l, " col: ", show c]
                                    AlexSkip  inp' len            -> go inp'
                                    AlexToken inp' len act        -> act pos (take len str) : go inp'

-- for building tokens which hold a value
storeValue     mkToken alexPos v = (mkToken v, makeFilePos alexPos)

-- for building tokens which discard the parsed string
discardValue   token alexPos _ = (token, makeFilePos alexPos)

dropEnds = init . tail

prop   = PropSymbol . read
nom    = N . read
var    = X . read
rel  r
  | null r    = defaultRel
  | otherwise =  RelSymbol (read . tail . dropWhile isSpace $ r)
relI   = inv . rel
defaultRel = RelSymbol 1
}